; courier 9pt -9 spacing tabs: .875 1.5 3.625
; modified GETEVENT to need nothing off of stack
; added lineto
; need to change modification in vers RSRC
;    Load equates for Toolbox, Quickdraw
	LIST OFF
	INCLUDE	"library.asm"
	INCLUDE	"equates.asm"
	INCLUDE	"yerk.macro"
newhandc	EQU	$a322
newPtrc	EQU	$a31e
waitNextEvt	EQU	$a860
	GLOBAL	$200,$200
	ENDG
	TFILE "YERK.BIN"
	RFILE "YERK",APPL,YERK,$2100	; has bundle,init
	SEG	1,52
*
origin	bra	ftInit	; branch around initialization da
one	EQU	origin
segStart	EQU	origin-4
lkorigin	EQU	origin	; null link for first entry
;		begin USER initialization data
;
Rsize	EQU	400	; Maximum depth of ret+mstack
Rbytes	EQU	-Rsize*4	; Number of bytes for ret+mstack
MSbytes	EQU	1200	; 300 cells on methods stack
HeapSiz	EQU	82000	; min size of heap given to system
maxDict	EQU	$3ffff	; max size of user dict to get
sysVects	EQU	17	; how many system vectors + 1 (for len)
sysVecSz	EQU	sysVects*4	; total len of system vector table
; 'SAVE' HEADER EQUATES.
udp	EQU	0	; User dictionary pointer
ufence	EQU	4	; User fence pointer
uvocl	EQU	8	; User vocabulary pointer
ulatest	EQU	12	; Latest NFA.
headlen	EQU	16	; Length of header
; Finder Handle Offsets
opflag	EQU	0	; Open/Print flag
numfiles	EQU	2	; Number of files
volrnum	EQU	0	; Volume reference number
ftype	EQU	2	; File type
fvernum	EQU	6	; File's version number
fname	EQU	8	; File name ( <count> <name> )
f.handle	EQU	16	; Offset to finder handle
YerkID	ASC	"3300"	; Release, version, revision, 0
	ADJST
initLast	DATA	Lastdef-origin	; origin + 12: last definition addr
initFenc	DATA	Lastdef-origin	; fence
initS0	DATA	0	; offset from A3 for initial A7 (SP)
initR0	DATA	0	; offset from A3 for initial A6
initmp	DATA	0	; offset from A3 for initial D5
initDP	DATA	0	; DP - starts past sys vector table
initVocl	DATA	0	; VOC-LINK - last COLD init
Userror	DATA	0	; Error during load
memsize	DATA	0	; Size of memory acquired
memPtr	DATA	0	; abs ptr to the user dict heap
userdp	DATA	0	; Pointer to the user dict heap
stksize	DATA	$ffffe078	; 8072 stack size
;
;	End USER initialization data
;
; Save environment passed in from Pascal main - address of buffer
;
ftInit	lea	memsize(PC),a0	; see if this is a reboot
	tst.l	(a0)	; if mem already acquired,
	bne	coldvec	; skip initialization code
	movem.l	A3/A4/A6/D3-D7,-(sp)	; save Pascal regs
;
; set up a6 to point to beginning of method stack, a7 set to
; beginning of data stack
;
	link	a6,#rbytes	; a6=R0,a7=S0 return stack
	pea	-4(a5)
	_InitGraf	; initGraf(@thePort)
	lea	origin(PC),a3	; a3 -> code base at load
	lea	stksize(PC),a0
	move.l	(a0),d1
	lea	0(a7,d1.l),a0	; leave stack space
	_setApplLimit
	_maxMem		; force purge of the heap
	jsr	loaduser(PC)	; load application dictionary if any
	moveq	#(initS0-origin),d7	; put offset into D7
	move.l	SP,d0	; store SP in d0
	sub.l	a3,d0	; reference to yerk base
	move.l	d0,0(a3,d7.l)	; inits0 now has offset to data stk
	move.l	a6,d0	; A6 points to methods stack
	sub.l	a3,d0	; reference to yerk base
	lea	initmp(PC),a2	; Init methods stack for cold load
	move.l	d0,(a2)	; initmp now has mstack offset
	subi.l	#msbytes,d0	; Leave 300 cells for M stack
	move.l	d0,4(a3,d7.l)	; initr0 now has offset to ret stk
*
COLDVEC	bra.s	ECLD	; jump to cold start
WARMVEC	bra.s	EWRM	; jump to warm start
; =======Inner Interpreter ===========
donext	move.l	(a4)+,d6	; get next threaded instruction (32bit)
	move.l	0(a3,d6.l),d7	; get code address
	jmp	0(a3,d7.l)	; jump to code addr relative to a3
	nop
ECLD	lea	cld1(PC),a4	; A4 is IP in inner interpreter
	bra.s	EWRM1
EWRM	lea	warm1(PC),a4	; A4 is IP in inner interpreter
EWRM1	lea	origin(PC),a3
	moveq	#(initS0-origin),d7	; get address of initS0 in D7
	movea.l	0(a3,d7.l),SP	; pickup s0 address in SP
	adda.l	a3,SP
	movea.l	4(a3,d7.l),a6	; pickup r0 address in a6
	adda.l	a3,a6
	move.l	initmp(PC),d5	; Pick methods stack pointer
	add.l	a3,d5
	jmp	donext(PC)
warm1	cfas	cls,abort,semis
; Loaduser routine loads the user dictionary if there is one to be loaded.
; First get some Heap to read the user dictionary into. We want
; get as much heap as there is available, minus some for the system.
loaduser
	lea	0(a7,d1.l),a0		
	lea	lastdef(PC),a1	; Top of nucleus
	suba.l	a1,a0	; Max. mem available
	move.l	a0,d0
heapWord
	subi.l	#heapsiz,d0	; Leave n k for other things.
	cmpi.l	#maxDict,d0	; leave more heap on big MACS
	blt	allHeap
	move.l	#maxDict,d0	; limit dict size
allheap
	lea	memsize(PC),a2	; small machine
	move.l	d0,(a2)	; Save memory size.
	lea	segStart(PC),a0	; segment start
	_RecoverHandle	; handle to CODE 1 segment
	addi.l	#(nextdef-origin+76),d0	; add in length of nucleus
	_SetHandleSize	; grow CODE 1 to accom user dict
	lea	nextdef+2(PC),a0	; clear newly acquired space
	move.l	(a2),d0
	asr.l	#2,d0	; number of long words to clear
clm	clr.l	(a0)+
	dbra	d0,clm
	lea	nextdef+2(PC),a0
	lea	memptr(PC),a2
	move.l	a0,(a2)	; Save the memory pointer
; set up DP
	suba.l	a3,a0	; a0 has relative base of user dict
	lea	initdp(PC),a2
	move.l	a0,(a2)	; Set default dp
	andi.l	#$FFFFFF,(a2)	; mask out hi byte
	add.l	#sysvecSz,(a2)	; bump dp past system vector table
*
	lea	userdp(PC),a2	; Save pointer to dict. begin
	move.l	a0,(a2)
	andi.l	#$FFFFFF,(a2)
	jsr	loadcom(PC)
	rts
;
; Get the finder handle and see if there is file to be opened
;
loadcom	movea.l	f.handle(a5),a0	; Get finder handle
	movea.l	(a0),a0	; Dereference it
	tst.w	(a0)	; Check if open or print
	beq	load010	; ok to open
	movea.l	#2,a0	; error. we don't print
	bra	loaderror
; The file is to be opened. See if there are any files to open.
load010
	tst.w	numfiles(a0)	; any files to open?
	bne	load020	; at least one
	movea.l	#1,a0	; none. just the nucleus
	bra	loaderror
; We have at least one file to be opened. Even if there are more than
; one at this point we are only going to open the first file picked.
load020
	adda.l	#4,a0	; a0 points past the header
	move.l	ftype(a0),a1	; get filetype of the file
	cmpa.l	#$434f4d20,a1	; is it 'COM ' ?
	bne	loaderror
	lea	usefcb(PC),a1	; load pointer to usefcb
	lea	fname(a0),a2	; load pointer to filename
	move.l	a2,IoFileName(a1)	; set file pointer in the fcb
	lea	(a0),a2	; load pointer to VRefNum
	move.w	(a2),IoVRefNum(a1)	; set VRefNum in the fcb
	move.b	#1,IoPermssn(a1)	; set i/o permission to readonly
	move.l	a1,a0	; Fcb in a0 for call
	_open		; Open the file
	tst.w	IoResult(a0)	; Check for errors
	beq	load030	; continue if ok
	movea.l	IoResult(a0),a0	; error code
	bra	loaderror	; Off to process errors
; Now get the file size so that we know how much to read in.
load030	
	movea.l	a1,a0	; get the fcb back in a0
	_getfileinfo	; get info on the file
	tst.w	IoResult(a0)	; Check for errors
	beq	load040	; continue if ok
	movea.l	IoResult(a0),a0	; error code
	bra	loaderror	; Off to process errors
load040
	lea	nextdef+2(PC),a4	; Get buffer addr
	move.l	IoflLgLen(a0),d1	; Get the logical length of file
	movea.l	a1,a0	; Fcb again
	move.l	a4,iobuffer(a0)	; Set buffer pointer for data in
	move.l	#headlen,IoReqCount(a0)	; Number of bytes to read
	clr.l	IoPosMode(a0)	; Read from beginning of file
	clr.l	IoPosOffset(a0)	; offset by 0
	_read
	tst.w	IoResult(a0)	; Check for errors
	beq	load060	; continue if ok
	movea.l	IoResult(a0),a0	; error code
	bra.s	loaderror	; Off to process errors
; Initialize COLD load variables so that the user dictionary is included
; when the FORTH system is brought up.
load060
	lea	initdp(PC),a2
	move.l	(a4),(a2)	; Set dictionary pointer
	lea	initfenc(PC),a2
	move.l	ufence(a4),(a2)	; Set fence pointer
	lea	initvocl(PC),a2
	move.l	uvocl(a4),(a2)	; Set vocabulary link
	lea	initLast(PC),a2
	move.l	ulatest(a4),(a2)	; Set latest NFA
; Now we can read the dictionary into the memory.
	subi.l	#headlen,d1	; Size of dictionary to read
	move.l	d1,IoReqCount(a0)
	clr.l	IoPosMode(a0)	; Position to beginning of file
	move.l	#headlen,IoPosOffset(a0)	; Offset by headlen
	_read		; read the dictionary
	tst.w	IoResult(a0)	; Check for errors
	beq	load070	; continue if ok
	movea.l	IoResult(a0),a0	; error code
loaderror
	lea	userror(PC),a2
	move.l	a0,(a2)	; Save error code for cold
	bra.s	load080
load070
	movea.l	a1,a0	; fcb again
	_close		; Close the file
load080
	rts
; --------------------------------------
; area for calls to Toolbox, etc.
ftwork	DEFS	20
ftwork1	DC.L	0
dsmsg	STR	"Parameter Stack:"
rsmsg	STR	"Return Stack:   "
msmsg	STR	"Methods Stack:  "
emptymsg	STR	"  <empty>"
pausemsg	STR	"Paused - <Space Bar> to continue>>>"
bytesleft	STR	"Bytes Available: "
hello	STR	"Macintosh YERK Version 3.3 "
	ADJST
tibbuf	DEFS	128	; terminal input buffer
	DATA	/0
	DEFS	20	; for numeric output
padbuf	DEFS	256	; text output buffer
aregn	DATA	0	; region handle for miscellany
	ADJST
; Begin nucleus definitions
	ADJST
cld1	cfas	xcold,quit	; do COLD word and enter Forth
; ====================================================
; Following are data areas that will be patched to look like objects
; after the Class/Object support code is in. Cfas will be patched to
; Class pointers.
; ====================================================
	dcode	FWIND,x,origin,fwind ; link should be 0
wRecord	
	DEFS	windowsize	; window record
	DC.W	40,2,290,494	; content rect boundaries
	DC.W	8,8,340,510	; grow rect boundaries
	DC.W	-10000,-10000,10000,10000	; drag rect boundaries
	DC.W	1,1,1	; growflg,dragflg, alive
	DATA	nulw-origin	; idle vector
	DATA	cls-origin	; deact vector
	DATA	nulw-origin	; content vector
	DATA	nulw-origin	; draw vector
	DATA	nulw-origin	; enact vector
	DATA	nulw-origin	; close vector
	DC.W	0	; resid
	dcode	FEVENT,x,fwind,fevent
eventRec	DC.W	0	; event record for GetNextEvent
eventMsg	DC.L	0,0,0
eventMod	DC.W	0
eventmsk	DC.W	0
eventSlp	DC.L	0
mousRgn	DC.L	0
	DC.W	4,16	; header for event indexed area
	DEFS	64
	dcode	FFCB,x,fevent,ffcb
; ------------- Default FCB ------------
useFCB	DEFS	144	; Parm block for USING file
useFname	DEFS	64	; holds USING volume/file name string
	DATA	0,0,0,0	; FCB reclen,ioRefnum,VolRefnum, bufptr
; -----------------------------------------
fcbl	EQU	*-useFCB	; length of FCB
	dcode	FPRECT,x,ffcb,fprect
pRect	DC.W	0,0,294,470	; Forth window rectangle
; =============================================================
	dcode	ADOC,x,fprect,adoc
	jsr	loadcom(PC)	; load user dict according to fInfo
	jmp	donext(PC)
; system values
	dval	S0,adoc,s0,0
	dval	R0,S0,r0,0
	dval	TIB,r0,tib,tibbuf-origin
	dval	WARNING,tib,warn,1
	dval	FENCE,warn,fence,0
	dval	DP,fence,dp,0
	dval	VOC-LINK,dp,vocl,0
	dval	IN,vocl,in,0
	dval	OUT,in,out,0
	dval	CONTEXT,out,contxt,0
	dval	CURRENT,contxt,currnt,0
	dval	STATE,currnt,state,0
	dval	CSTATE,state,cstate,0
	dval	BASE,cstate,base,10
	dval	DPL,base,dpl,0
	dval	CSP,dpl,csp,0
	dval	HLD,csp,hld,0
	dval	WNEAVAIL,hld,wneavail,0	; true if waitNextEvent in ROM
	dval	HWPAVAIL,wneavail,hwpavail,0	; true if flush cache
	dvect	VMODEL,hwpavail,vmodel,nulw	; model for other vectors
	dcon	NEXT,vmodel,next,donext
	dcon	MPATCH,next,mpatch,heapword+2	; addr of heap size patch
	dcon	BEGIN-DP,mpatch,bdp,userdp	; use @
	dcon	LOAD-ERROR,bdp,lerror,Userror	; use @
	dval	M0,lerror,m0,0
	dcon	WSIZE,m0,winsiz,windowsize+origin
	dcon	CTLSIZE,winsiz,ctlsiz,contrlsize+origin
	dcon	USE-FCB,ctlsiz,ufcb,useFCB	; pushes addr of useFCB
	dcon	MSIZE,ufcb,msiz,memsize	; use @
	dcon	BL,msiz,bl,$20+origin
	dcon	TRUE,bl,true,1+origin
	dcon	FALSE,true,false,0+origin
	dsvect	KEYVEC,false,keyvec,4,key_	; system vectors for I/O
	dsvect	EMITVEC,keyvec,emitvec,8,emit_	; console emit
	dsvect	PEMITVEC,emitvec,pemitv,12,drop	; printer emit
	dsvect	TYPEVEC,pemitv,typevec,16,type_	; console type
	dsvect	PTYPEVEC,typevec,ptypev,20,drop2
	dsvect	EXPVEC,ptypev,expvec,24,expect	; expect
	dsvect	ECHOVEC,expvec,echovec,28,emit_	; echo for keys
	dsvect	ABORTVEC,echovec,abvec,32,nulw	; installable abo
	dsvect	QUITVEC,abvec,quvec,36,nulw	; installable startup vector
	dsvect	UFIND,quvec,ufind,40,false	; vector for user find
	dsvect	OBJINIT,ufind,objini,44,nulw	; init nucleus objs
	dsvect	PCRVEC,objini,pcrvec,48,nulw	; printer CR
	dsvect	BLDVEC,pcrvec,bldvec,52,nulw	; object builder
	dsvect	CREATE,bldvec,kreate,56,creat_	; create vector
	dsvect	INTERPRET,kreate,interp,60,intrp_
	dsvect	CRVEC,interp,crvec,64,cr_
	dval	DISK-ERROR,crvec,dkerr,0
	dval	CURS,dkerr,curs_,1	; cursor on/off flag
crsflag	EQU	*-4
	dval	UCFLAG,curs_,ucflag,1	; map to upper case
; ==============================================
	dcode	BYE,x,ucflag,bye_
	_exitToShell
*
	dcode	(CODEZONE),x,bye_,instal
	lea	segStart(PC),a1	; set CODE 1 resource size
	movea.l	a1,a0
	_recoverHandle	; get a handle to appl
	move.l	(a7)+,d0	; get ending rel addr
	addq.l	#1,d0
	andi.l	#-2,d0	; ensure even
	addi.l	#$4c,d0	; add header length
	_SetHandleSize	; increase the size
	jmp	donext(PC)
*
	dcode	FINFO,x,instal,finfo	; point to finder handle
	movea.l	f.handle(a5),a0
	movea.l	(a0),a0	; dereference
	suba.l	a3,a0	; make relative
	move.l	a0,-(SP)	; push dereferenced ptr
	jmp	donext(PC)
*
	dcode	.CUR,x,finfo,dotcur	; draw a cursor
pcurs1	jsr	pcurs(PC)
	jmp	donext(PC)
*
pcurs	lea	crsflag(PC),a0	; ( -- )
	tst.l	(a0)	; is cursor on or off?
	beq	nocurs
	pea	ftwork(PC)
	_GetPenState	; get the current pen state
	move.w	#10,-(SP)	; set xor mode
	_PenMode
	move.w	#7,-(SP)
	clr.w	-(SP)
	_Line
	pea	ftwork(PC)
	_SetPenState
nocurs	rts
*
	dcode	(EMIT),x,dotcur,emit_
	jsr	pcurs(PC)
	addq.l	#2,SP	; long -> integer
	_DrawChar	; expects Pascal CHAR on stack
	jsr	pcurs(PC)
	jmp	donext(PC)
*
	dcode	(TYPE),x,emit_,type_
	move.l	a3,d0
	add.l	d0,4(SP)	; make address absolute
	clr.l	d0
	move.w	2(SP),d0
	swap	d0
	move.l	d0,(SP)	; zero start byte offset
	_DrawText
	jsr	pcurs(PC)
	jmp	donext(PC)
*
	dcode	NULW,x,type_,nulw	; empty word for stubbing vectors
	jmp	donext(PC)
*
	dcode	WORD0,x,nulw,word0	; push a word of 0 for function setup
	clr.w	-(SP)
	jmp	donext(PC)
*
	dcode	PACK,x,word0,pack_	; packs 2 longs into one
	popd0		; get y
	addq.l	#2,SP
	move.w	d0,-(SP)
	jmp	donext(PC)
*
	dcode	UNPACK,x,pack_,unpack
	move.l	(sp),d0
	move.w	d0,d1
	ext.l	d1
	move.l	d1,(SP)
	asr.l	#8,d0
	asr.l	#8,d0
	move.l	d0,-(SP)
	jmp	donext(PC)
*
	dcode	I->L,x,unpack,itol	; extend 16 bit stack cell to 32
	move.w	(sp)+,d0
	ext.l	d0
	move.l	d0,-(SP)
	jmp	donext(PC)
*
	dcode	MAKEINT,x,itol,makint
	addq.l	#2,SP	; drop high-level word on stack
	jmp	donext(PC)
*
	dcode	NEWPTR,x,makint,xnewpt
	popd0		; get size for new block in d0
	_NewPtrC		; call the memory manager for a new block
	sub.l	a3,a0	; make ptr relative
	move.l	a0,-(SP)	; push ptr to nonrelocatable block
	jmp	donext(PC)
*
	dcode	NEWHANDLE,x,xnewpt,xnewha
	popd0
	_newHandC	; special vers of _NewHandle
	move.l	a0,-(SP)	; push handle to relocatable block
	jmp	donext(PC)
*
	dcode	LOCK,x,xnewha,xlock
	movea.l	(SP),a0	; get handle in a0
	_hLock		; mark the block locked
	movea.l	(SP),a0
	movea.l	(a0),a1	; dereference the handle
	suba.l	a3,a1	; make it a Forth address based on a3
	move.l	a1,(SP)	; leave Forth address on stack
	jmp	donext(PC)
*
	dcode	KILLPTR,x,xlock,killpt	; (relPtr -- )
	movea.l	(SP)+,a0	; get rel ptr in a0
	add.l	a3,a0	; make it absolute
	_disposPtr	; release it
	jmp	donext(PC)
*
	dcode	KILLHANDLE,x,killpt,killha
	movea.l	(SP)+,a0	; get handle
	_disposHandle
	jmp	donext(PC)
*	
	dcode	GROWPTR,x,killha,groptr	; ( bytes relptr --)
	movea.l	(SP)+,a0	; get rel ptr in a0
	adda.l	a3,a0	; make it absolute
	move.l	a0,d4
	_getPtrSize
	add.l	(sp)+,d0	; get new handle size
	movea.l	d4,a0
	_SetPtrSize	; grow the block
	jmp	donext(PC)
*
	dcode	FREE,x,groPtr,free_	; ( -- maxAvail )
	_freeMem		; what is max mem avail on heap?
	pushd0		; includes purging
	jmp	donext(PC)
*
	dcode	FREEBLK,x,free_,freblk
	_maxmem		; what is max mem avail on heap?
	pushd0		; includes purging
	jmp	donext(PC)
*
	dcode	>PTR,x,freblk,fetptr	; ( handle	--- relptr )
	movea.l	(SP),a0
	move.l	(a0),d0	; dereference a handle
	andi.l	#$ffffff,d0	; mask out hi byte
	sub.l	a3,d0
	move.l	d0,(SP)	; return its pointer
	jmp	donext(PC)
*
	dcode	GET-EVENT,x,fetptr,getevt
	move.l	(SP)+,d7	; get event mask into d7
	swap	d7
ev1	move.l	d7,-(SP)	; make room for function return
	lea	eventRec(PC),a0	; ptr to event rec storage
	move.l	a0,-(sp)
	tst.b	wneavail9+3-origin(a3)	; is waitnextevent here?
	beq.s	usegne0
	move.l	18(a0),-(sp)	; get sleep value
	move.l	22(a0),-(sp)	; get mouse rgn
	_waitNextEvt
	bra.s	endevt0
usegne0	_SystemTask	; WNE not in ROM
	_GetNextEvent
endevt0	tst.w	(SP)+	; should we handle this event?
	beq	ev1	; no - get another one
	lea	eventRec(PC),a0
	clr.l	d0
	move.w	(a0),d0	; pick up event type
	beq.s	ev1	; loop if null event
	pushd0		; push event type for caller
	jmp	donext(PC)
*
	dcode	?EVENT,x,getevt,qevt
	move.l	(SP)+,d7	; get event mask into d0
	swap	d7
	move.l	d7,-(SP)	; make room for function return
	pea	eventRec(PC)	; pointer to event rec storage
	_EventAvail	; call Toolbox
	tst.w	(SP)+	; should we handle this event?
	beq	event1	; no - return false
	lea	eventRec(PC),a0
	clr.l	d0
	move.w	(a0),d0	; pick up event type
	beq	event1	; loop if null event
event2	move.l	#1,-(SP)	; push true - event available
	bra.s	event3
event1	clr.l	-(SP)	; push false - no event available
event3	jmp	donext(PC)
*
	dcode	GETEVENT,x,qevt,gevt	; (  --- b )
	clr.w	-(sp)	; make room for function return
	lea	eventRec(PC),a0
	move.w	eventMsk-eventRec(a0),-(sp)	; get event mask
	move.l	a0,-(sp)
	tst.b	wneavail9+3-origin(a3)	; is waitnextevent here?
	beq.s	usegne
	move.l	18(a0),-(sp)	; get sleep value
	move.l	22(a0),-(sp)	; get mouse rgn
	_waitNextEvt
	bra.s	endevt
usegne	_SystemTask	; WNE not in ROM
	_GetNextEvent
endevt	clr.w	-(SP)	; make an integer a long
	jmp	donext(PC)
*
	dcode	@EVENT-MSG,x,gevt,ftemsg
	lea	eventMsg(PC),a0
	move.l	(a0),-(SP)	; push contents of last event msg
	jmp	donext(PC)
*
; FIND-WINDOW ( point -- region, wptr )
	dcode	FIND-WINDOW,x,ftemsg,findw
	popd0
	clr.w	-(SP)
	pushd0
	pea	ftwork1(PC)
	_FindWindow
	clr.w	-(SP)
	lea	ftwork1(PC),a0
	move.l	(a0),d0
	sub.l	a3,d0
	pushd0
	jmp	donext(PC)
	dcode	INIT-TOOLS,x,findw,intool
	_InitFonts
	move.l	#$ffff,d0	; every event rfl 10/89
	_FlushEvents
	_InitWindows
	_TEInit
	pea	EWRM(PC)	; warm start for Resume button
;in deep shit
	_InitDialogs
	clr.l	-(SP)	; for windowPtr return
	move.w	#256,-(SP)	; window ID
	pea	wrecord(PC)
	move.l	#-1,-(SP)	; POINTER(-1) for front window
	_GetNewWindow	; get window resource def
	_setPort		; setPort(WindowPtr)
	lea	wrecord(PC),a0
	move.w	#9,txSize(a0)	; window text size = 9
	move.w	#4,txfont(a0)	; window text font
	lea	pRect(PC),a1
	move.l	portRect(a0),(a1)
	move.l	portRect+4(a0),4(a1)
	clr.l	-(SP)
	_NewRgn
	lea	aRegn(PC),a0
	move.l	(SP)+,(a0)	; fill in region handle
	clr.w	-(SP)
	_TextMode	; source copy text mode
	_Initmenus
	_InitCursor
	move.w	#$a09f,d0	; check for trap availability
	_getTrapAddress+$600
	move.l	a0,d3	; d3 = unimplemented trap addr
	move.w	#$a860,d0
	_getTrapAddress+$600
	cmp.l	a0,d3	; if <> waitnextevent is avail
	sne	d0
	move.b	d0,wneavail9+3-origin(a3)
	move.l	#$a198,d0	; get hwpriv trap addr
	_getTrapAddress+$200
	cmp.l	a0,d3	; if <> hwpriv is avail
	sne	d0
	move.b	d0,hwpavail9+3-origin(a3)
	jmp	donext(PC)
*
	dcode	HOME,x,intool,home
dohome	move.l	#$f0008,d0
	pushd0
	_MoveTo		; home
	jmp	donext(PC)
*
	dcode	CLS,x,home,cls
	pea	pRect(PC)
	_EraseRect
	jmp	dohome(PC)
	jmp	donext(PC)
*
	dcode	SCROLL,x,cls,scroll	; (dh dv --- )
	popd0
	popd1
	pea	pRect(PC)
	move.w	d1,-(SP)
	move.w	d0,-(SP)
	lea	aregn(PC),a0	; get dummy region handle
	move.l	(a0),-(SP)
	_ScrollRect
	jmp	donext(PC)
*
	dcode	>ORIGIN,x,scroll,setorg
	popd0
	addq.l	#2,SP
	move.w	d0,-(SP)
	_SetOrigin
	jmp	donext(PC)
*
	dcode	LINE,x,setorg,xline	; (dh dv ---)
	popd0
	addq.l	#2,SP
	move.w	d0,-(SP)
	_Line
	jmp	donext(PC)
*
	dcode	LINETO,x,xline,xline2	; (x y --)
	popd0
	addq.l	#2,SP
	move.w	d0,-(sp)
	_LineTo
	jmp	donext(PC)
*
	dcode	LIT,x,xline2,lit ; build code header
	move.l	(a4)+,-(SP)	; push value at IP to stack
	jmp	donext(PC)
*
	dcode	WLIT,x,lit,wlit	; build code header
	move.w	(a4)+,-(SP)	; push value at IP to stack
	clr.w	-(SP)	; extend to 32 bits
	jmp	donext(PC)
*
	dcode	WLITW,x,wlit,wlitw	; build code header
	move.w	(a4)+,-(sp)	; push value at IP to stack
	jmp	donext(PC)	; no extend
*	
	dcode	W@(IP),x,wlitw,wfetip
	move.l	(a6),d0	; get IP from 1 nest back
	move.w	0(a3,d0.l),-(SP)	; push the word
	clr.w	-(SP)
	add.l	#2,(a6)	; increment old IP past word
	jmp	donext(PC)
*
	dcode	EXECUTE,x,wfetip,exec
	move.l	(SP)+,d6	; pop address to execute
	move.l	0(a3,d6.l),d7	; get contents of CFA
	jmp	0(a3,d7.l)	; execute the code
*
	dcode	TRAP,x,exec,trap_	; execute passed-in Tool trap
	popD0		; get trap in d0
	lea	trapword(PC),a0
	move.w	d0,(a0)	; store trap inline for execution
	nop		; so we don't get burned by prefetch
trapword	DC.W	$A997	; start with openresfile
	jmp	donext(PC)
*
	dcode	GOTOXY,x,trap_,gotoxy
	popd0		; get Y in d0
	addq.l	#2,SP	; drop high-level word on stack
	move.w	d0,-(SP)
	_MoveTo		; call Quickdraw to move pen
	jmp	donext(PC)
*
	dcode	BEEP,x,gotoxy,beep	; ( dur -- )
	addq.l	#2,sp
	_sysbeep
	jmp	donext(PC)
*
	dcode	@XY,x,beep,fetxy	; return X,Y pen location
	pea	ftwork(PC)
	_GetPen
	lea	ftwork(PC),a0
	clr.l	d0
	move.w	2(a0),d0
	pushd0		; push X value
	move.w	(a0),d0
	pushd0		; push Y value
	jmp	donext(PC)
*
	dcode	BRANCH,x,fetxy,bran
	adda.l	(a4),a4	; add relative offset to IP
	jmp	donext(PC)
*
	dcode	0BRANCH,x,bran,bran0
	move.l	(SP)+,d0	; pop data stack into d0
	bne	br1	; if non-0, ignore branch following
	adda.l	(a4),a4	; else take the branch
	bra.s	br2
br1	addq.l	#4,a4	; next 32-bit cfa
br2	jmp	donext(PC)
*
	dcode	OFBR,x,bran0,ofbr	; 0branch used by OF clauses
	move.l	(SP)+,d0	; pop data stack into d0
	bne	ofbr1	; if non-0, ignore branch
	move.l	(a6),d1	; get IP from return stack
	move.l	0(a3,d1.l),d2
	add.l	d2,(a6)	; add to stacked IP
	bra.s	ofbr2
ofbr1	addq.l	#4,(a6)	; next 32-bit cfa 1 nest back
	addq.l	#4,SP	; drop the value
ofbr2	jmp	donext(PC)
*
	dcode	FAKE,x,ofbr,fake_	; use as a breakpoint with debugg
	jmp	*(PC)
	jmp	donext(PC)
*
	dcode	(LOOP),x,fake_,loop_	; (loop)
	addq.l	#1,(a6)	; bump index (long)
	move.l	(a6),d0
	cmp.l	4(a6),d0	; compare index to limit
	bge	xloop1
	adda.l	(a4),a4	; branch back to top of loop
	jmp	donext(PC)
xloop1	addq.l	#8,a6	; pop index,limit from return stack
	addq.l	#4,a4
	jmp	donext(PC)
*
	dcode	(DO),x,loop_,do_	; this DO terminates on limit=count
	move.l	(SP),d0
	cmp.l	4(SP),d0	; does limit=count? if so, terminate
	bne	doloop
	adda.l	(a4),a4	; forward jump IP
	addq.l	#8,SP
	jmp	donext(PC)
doloop	move.l	4(SP),-(a6)	; limit val to Return stack
	move.l	d0,-(a6)	; start val
	addq.l	#4,a4	; skip the jump addr
	addq.l	#8,SP
	jmp	donext(PC)
*
	dcode	(LOOP+),x,do_,ploop_
	move.l	(SP)+,d0
	bmi	xploop1
	add.l	d0,(a6)
	move.l	(a6),d0
	cmp.l	4(a6),d0
	bge	xploop2
	adda.l	(a4),a4
	bra.s	xploop3
xploop1	add.l	D0,(a6)
	move.l	(a6),d0
	cmp.l	4(a6),d0
	ble	xploop2
	adda.l	(a4),a4
	bra.s	xploop3
xploop2	addq.l	#8,a6
	addq.l	#4,a4
xploop3	jmp	donext(PC)
*
	dcode	I,x,ploop_,i
	move.l	(a6),-(SP)
	jmp	donext(PC)
*
	dcode	I+,x,i,iplus	; add I to top of stack
	move.l	(a6),d0
	add.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	I-,x,iplus,iminus
	move.l	(a6),d0
	sub.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	I@,x,iminus,ifetch	; fetch from I as addr
	move.l	(A6),d7
	move.l	0(a3,d7.l),-(sp)
	jmp	donext(PC)
*
	dcode	I!,x,ifetch,istore
	move.l	(A6),d7
	move.l	(SP)+,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	IC@,x,istore,icfet
	clr.l	d0
	move.l	(a6),d7
	move.b	0(a3,d7.l),d0
	move.l	d0,-(SP)
	jmp	donext(PC)
*
	dcode	IC!,x,icfet,icstor
	move.l	(A6),d7
	move.l	(sp)+,d0
	move.b	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	J,x,icstor,j
	move.l	8(a6),-(SP)
	jmp	donext(PC)
*
	dcode	DIGIT,x,j,digit
	popd0
	popd1
	clr.l	d2
	subi.l	#$30,d1
	bmi	dig2
	cmpi.l	#$0a,d1
	bmi	dig1
	subq.l	#7,d1
	cmpi.l	#$0a,d1	; to fix FIG bug that lets 58-64 pass
	bmi	dig2
dig1	cmp.l	d0,d1
	bge	dig2
	moveq	#1,d2
	pushd1
dig2	pushd2
	jmp	donext(PC)
*
	dcode	TRAVERSE,x,digit,traver
	popd0
	popd1
	moveq	#$20,d2
	lea	0(a3,d1.l),a0
	tst.l	d0
	bmi	trav1
	move.b	(a0),d0
	andi.l	#$1f,d0
	adda.l	d0,a0
	move.l	a0,d0
	andi.l	#1,d0
	suba.l	d0,a0
	addq.l	#1,a0
	bra.s	trav2
trav1	tst.b	(a0)
	bmi	trav2
	subq.l	#1,d2	; exit early if drags on
	beq	trav2
	subq.l	#1,a0
	bra.s	trav1
trav2	suba.l	a3,a0
	move.l	a0,-(SP)
	jmp	donext(PC)
*
	dcode	(FIND),x,traver,find_
	clr.l	d1
	move.l	(SP)+,d7
	lea	0(a3,d7.l),a0
pfind1	movea.l	a0,a2
	move.l	(SP),d7
	lea	0(a3,d7.l),a1
	move.b	(a2)+,d1
	andi.l	#$03f,d1
	cmp.b	(a1)+,d1
	bne	pfind3
	move.l	d1,d0
pfind2	cmpm.b	(a1)+,(a2)+
	bne	pfind3
	subq.l	#1,d0
	bne.s	pfind2
	bsr	odd
	addq.l	#8,a2
	suba.l	a3,a2
	move.l	a2,(SP)
	move.b	(a0),d0
	pushD0
	moveq	#1,d0
	bra.s	pfind4
pfind3	movea.l	a0,a2
	andi.w	#$1f,d1
	adda.l	d1,a2
	addq.l	#1,a2
	bsr	odd
	move.l	(a2),d7
	lea	0(a3,d7.l),a0
	tst.l	(a2)
	bne.s	pfind1
	addq.l	#4,SP
	clr.l	d0
pfind4	pushD0
	jmp	donext(PC)
odd	move.l	a2,d0
	moveq	#1,d1
	and.l	d1,d0
	adda.l	d0,a2
	rts
*
; ( SelPfa ^class -- f OR 1cfa t)
	dcode	((FINDM)),x,find_,findm_
	move.l	(SP)+,d7	; get relative ^class
	move.l	(SP)+,d0	; get SelPfa to match
	move.l	0(a3,d7.l),d7	; get contents of ^methods link field
findm0	lea	0(a3,d7.l),a1	; get absolute ^methods dict nfa
findm1	cmp.w	(a1),d0	; is this the method we want?
	beq	foundm	; yes, we found the method
	move.l	2(a1),d7	; link to previous method entry
	beq	notfndm	; end of methods dict - not found
	bra.s	findm0
foundm	addi.l	#10,d7	; point to 1cfa of method
	move.l	d7,-(SP)	; push 1cfa to stack
	move.l	#1,-(SP)	; true
	bra.s	fmexit	; return to Forth
notFndm	clr.l	-(SP)
fmexit	jmp	donext(PC)
*
*	( addr delim -- addr n1 n2 n3 )
	dcode	ENCLOSE,x,findm_,enclos
	popd0		; get delim in d0
	move.l	(SP),d7	; addr in d7
	lea	0(a3,d7.l),a0	; a0 has abs addr
	clr.l	d1
encGet	move.b	(a0)+,d2	; get next byte in d2
	beq	encNull	; null - unconditional exit
	cmpi.b	#9,d2	; is char a Tab?
	bne	notab1
	move.b	#32,d2	; map tabs to spaces
notab1	cmp.b	d0,d2	; does first char = delim?
	bne	encNext	; no
	addq.l	#1,d1	; get another char
	bra.s	encGet
encNull	pushd1		; found null- push idx at null
	addq.l	#1,d1	; push idx of byte following
	pushd1
	bra.s	encl5	; exit
encNext	pushd1		; idx of first non-delim
	subq.l	#1,a0
encl3	move.b	(a0)+,d2
	beq	encl4
	cmp.b	#9,d2	; is char a Tab?
	bne	notab2
	move.b	#32,d2	; map tabs to spaces
notab2	cmp.b	d0,d2
	beq	encl4
	addq.l	#1,d1
	bra.s	encl3
encl4	move.l	d1,-(SP)
	tst.b	d2
	beq	encl5
	addq.l	#1,d1
encl5	pushd1		; push unexamined idx and leave
	jmp	donext(PC)
*
	dcode	(S=),x,enclos,sequ_	; ( addr addr len -- b)
	popd0		; get length of string comparison
	subq.l	#1,d0	; setup counter for dbeq
	movea.l	(SP)+,a0
	movea.l	(SP)+,a1
	adda.l	a3,a0
	adda.l	a3,a1
dosequ	cmpm.b	(a0)+,(a1)+
	dbne	d0,dosequ
	cmp.w	#-1,d0
	beq	xsequ	; counter was exhausted, so true
	clr.l	-(SP)	; push false
	bra.s	nextsequ
xsequ	move.l	#1,-(SP)	; push true
nextsequ	jmp	donext(PC)
*
	dcode	CMOVE,x,sequ_,cmove
docmove	move.l	(SP)+,d0
	movea.l	(SP)+,a1
	movea.l	(SP)+,a0
	adda.l	a3,a0
	adda.l	a3,a1
cmov1	_BlockMove
	jmp	donext(PC)
*
; the somewhat dreaded multiply routines
mpy	move.l	(SP)+,-(a6)	; save return address from jsr
	tst.w	(SP)	; try short multiply first
	bne	mpy1
	tst.w	4(SP)	; if both high words=0, we
	bne	mpy1	; can do a short multiply
	popd0
	popd1
	mulu	d0,d1
	pushd1
	clr.l	d1
	pushd1
	move.l	(a6)+,-(SP)
	rts
mpy1	popd0		; this is long multiply
	popd1
	moveq	#0,d2
	move.l	d2,-(SP)
	move.l	d2,-(SP)
	move.w	d1,d2
	mulu	d0,d2
	move.l	d2,4(SP)
	move.l	d1,d2
	swap	d2
	mulu	d0,d2
	add.l	d2,2(SP)
	swap	d0
	move.w	d1,d2
	mulu	d0,d2
	add.l	d2,2(SP)
	bcc	mpy2
	addq.w	#1,(SP)
mpy2	move.l	d1,d2
	swap	d2
	mulu	d0,d2
	add.l	d2,(SP)
	move.l	(a6)+,-(SP)
	rts
smpy	move.l	(SP)+,-(a6)
	tst.l	(SP)	; signed multiply
	smi	d4
	bpl	smpy1
	neg.l	(SP)
smpy1	tst.l	4(SP)
	smi	d3
	bpl	smpy2
	neg.l	4(SP)
smpy2	eor.b	d3,d4
	bsr.s	mpy
	tst.b	d4
	beq	smpy3
	neg.l	4(SP)
	negx.l	(SP)
smpy3	move.l	(a6)+,-(SP)
	rts
xdiv	move.l	(SP)+,-(a6)
	tst.l	(SP)
	beq	div5
	tst.w	(SP)
	bne	longdiv
	tst.l	4(SP)
	bne	longdiv
	move.l	(SP)+,d2
	popd0
	popd1
	divu	d2,d1
	bvs	long1
	clr.l	d2
	move.w	d1,d2
	clr.w	d1
	swap	d1
	pushd1
	move.l	d2,-(SP)
	move.l	(a6)+,-(SP)
	rts
longdiv	move.l	(SP)+,d2	; the dreaded long division
	popd0
	popd1
long1	moveq	#32,d3
	sub.l	d2,d0
div1	bmi	div2
	ori.l	#1,d1
	subq.w	#1,d3
	bmi	div3
	asl.l	#1,d1
	roxl.l	#1,d0
	sub.l	d2,d0
	bra.s	div1
	
div2	subq.w	#1,d3
	bmi	div3
	asl.l	#1,d1
	roxl.l	#1,d0
	add.l	d2,d0
	bra.s	div1
div3	tst.l	d0
	bpl	div4
	add.l	d2,d0
div4	pushd0
	pushd1
	move.l	(a6)+,-(SP)
	rts
div5	addq.l	#4,SP
	move.l	d2,4(SP)
	move.l	#$7fffffff,(SP)
	move.l	(a6)+,-(SP)
	rts
sdiv	move.l	(SP)+,-(a6)	; save return address from jsr
	tst.l	(SP)	; signed divide
	smi	d4
	bpl	sdiv1
	neg.l	(SP)
sdiv1	tst.l	4(SP)
	smi	d7
	bpl	sdiv2
	neg.l	8(SP)
	negx.l	4(SP)
sdiv2	eor.b	d4,d7
	bsr	xdiv
	tst.b	d7
	beq	sdiv3
	neg.l	(SP)
sdiv3	tst.b	d4
	beq	sdiv4
	neg.l	4(SP)
sdiv4	move.l	(a6)+,-(SP)
	rts
slmod	move.l	(SP)+,-(a6)
	moveq	#0,d1
	popd0
	tst.l	(SP)
	bpl	slmod1
	subq.l	#1,d1
slmod1	pushd1
	pushd0
	move.l	(a6)+,-(SP)
	bra.s	sdiv
*
	dcode	U*,x,cmove,ustar
	bsr	mpy
	jmp	donext(PC)
*
	dcode	U/,x,ustar,uslash
	bsr	xdiv
	jmp	donext(PC)
*
	dcode	M*,x,uslash,mstar
	bsr	smpy
	jmp	donext(PC)
*
	dcode	M/,x,mstar,mslash
	bsr	sdiv
	jmp	donext(PC)
*
	dcode	*/,x,mslash,starsla
	move.l	(SP)+,-(a6)
	bsr	smpy
	move.l	(a6)+,-(SP)
	bsr	sdiv
	move.l	(SP)+,(SP)
	jmp	donext(PC)
*
	dcode	*/MOD,x,starsla,ssmod
	move.l	(SP)+,-(a6)
	bsr	smpy
	move.l	(a6)+,-(SP)
	bsr	sdiv
	jmp	donext(PC)
*
	dcode	M/MOD,x,ssmod,msmod
	move.l	(SP)+,-(a6)
	moveq	#0,d0
	pushd0
	move.l	(a6),-(SP)
	bsr	xdiv
	move.l	(a6)+,d0
	move.l	(SP)+,-(a6)
	pushd0
	bsr	xdiv
	move.l	(a6)+,-(SP)
	jmp	donext(PC)
*
	dcode	*,x,msmod,star	; *
	bsr	smpy
	addq.l	#4,SP	; drop top of stack
	jmp	donext(PC)
*
	dcode	/,x,star,slash	; /
	bsr	slmod
	move.l	(SP)+,(SP)
	jmp	donext(PC)
*
	dcode	/MOD,x,slash,xslmod	; /MOD
	bsr	slmod
	jmp	donext(PC)
*
	dcode	MOD,x,xslmod,mod	; MOD
	bsr	slmod
	addq.l	#4,SP
	jmp	donext(PC)
*
	dcode	D>,x,mod,dgrt	; D>
	moveq	#1,d0
	move.l	8(SP),d1
	cmp.l	(SP),d1
	bgt	dgrt1
	move.l	12(SP),d1
	cmp.l	4(SP),d1
	bgt	dgrt1
	moveq	#0,d0
dgrt1	adda.l	#16,SP
	pushd0
	jmp	donext(PC)
*
	dcode	D<,x,dgrt,dless	; D<
	moveq	#1,d0
	move.l	8(SP),d1
	cmp.l	(SP),d1
	blt	dless1
	move.l	12(SP),d1
	cmp.l	4(SP),d1
	blt	dless1
	moveq	#0,d0
dless1	adda.l	#16,SP
	pushd0
	jmp	donext(PC)
*
	dcode	D=,x,dless,dequ	; D=
	move.l	(SP),d1
	cmp.l	8(SP),d1
	seq	d0
	move.l	4(SP),d1
	cmp.l	12(SP),d1
	seq	d1
	adda.l	#16,SP
	and.l	d1,d0
	bra	setbyt
	jmp	donext(PC)
*
	dcode	U<,x,dequ,uless
	cmp2
	scs	d0
	bra.s	setbyt
*
	dcode	U>,x,uless,ugrt
	cmp2
	scc	d0
	bra.s	setbyt
*
	dcode	<,x,ugrt,less	; <
	cmp2
	slt	d0
	bra.s	setbyt
*
	dcode	>,x,less,grt	; >
	cmp2
	sgt	d0
	bra.s	setbyt
*
	dcode	=,x,grt,equals	; =
	cmp2
	seq	d0
	bra.s	setbyt
*
	dcode	<>,x,equals,nequals
	cmp2
	sne	d0
	bra.s	setbyt
*
	dcode	0=,x,nequals,zequ
	tst.l	(SP)+
	seq	d0
	bra.s	setbyt
*
	dcode	0<,x,zequ,zless
	tst.l	(SP)+
	smi	d0
setbyt	moveq	#1,d1
	and.l	d1,d0
	pushD0
	jmp	donext(PC)
*
	dcode	0>,x,zless,zgrt
	tst.l	(SP)+
	sgt	d0
	bra.s	setbyt
*
	dcode	<=,x,zgrt,lesequ
	cmp2
	sle	d0
	bra.s	setbyt
*
	dcode	>=,x,lesequ,grtequ
	cmp2
	sge	d0
	bra.s	setbyt
*
	dcode	0!,x,grtequ,zstore	; store 0 at addr
	move.l	(sp)+,d7
	clr.l	0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	0,x,zstore,pzer	; short, fast 0 word
	clr.l	-(SP)
	jmp	donext(PC)
*
	dcode	1,x,pzer,pone	; short, fast 1 word
	move.l	#1,-(SP)
	jmp	donext(PC)
*
	dcode	-1,x,pone,pmone	; short, fast -1 word
	move.l	#-1,-(SP)
	jmp	donext(PC)
*
	dcode	2,x,pmone,ptwo	; short, fast 2 word
	move.l	#2,-(SP)
	jmp	donext(PC)
*
	dcode	4,x,ptwo,pfour
	move.l	#4,-(SP)
	jmp	donext(PC)
*
	dcode	AND,x,pfour,and_
	popD0
	and.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	LAND,x,and_,land_
	popd0
	tst.l	(SP)
	beq	land2
	move.l	#1,(SP)
	tst.l	d0
	beq	land1
	moveq	#1,d0
land1	and.l	d0,(SP)
land2	jmp	donext(PC)
*
	dcode	OR,x,land_,or_
	popD0
	or.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	LOR,x,or_,lor_
	popd0
	tst.l	d0
	beq	lor1
	moveq	#1,d0
lor1	tst.l	(SP)
	beq	lor2
	move.l	#1,(SP)
lor2	or.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	XOR,x,lor_,xor
	popD0
	eor.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	LXOR,x,xor,lxor
	popd0
	tst.l	d0
	beq	lxor1
	moveq	#1,d0
lxor1	tst.l	(SP)
	beq	lxor2
	move.l	#1,(SP)
lxor2	eor.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	HERE,x,lxor,here
	move.l	#(dp9-origin),d7
	move.l	0(a3,d7.l),-(SP)
	jmp	donext(PC)
*
	dcode	ALLOT,x,here,allot
	move.l	#(dp9-origin),d7
	popD0
	add.l	d0,0(a3,d7.l)	; increment DP
	jmp	donext(PC)
*
	dcode	SP@,x,allot,spfet
	move.l	SP,d0
	sub.l	a3,d0
	pushD0
	jmp	donext(PC)
*
	dcode	SP!,x,spfet,spstor
	move.l	#(s09-origin),d7
	move.l	0(a3,d7.l),d7
	lea	0(a3,d7.l),SP	; add a3 to it and store in SP
	jmp	donext(PC)
*
	dcode	RP@,x,spstor,rpfet
	move.l	a6,d0
	sub.l	a3,d0
	pushD0
	jmp	donext(PC)
*
	dcode	RP!,x,rpfet,rpstor
	move.l	#(r09-origin),d7
	move.l	0(a3,d7.l),d7
	lea	0(a3,d7.l),a6	; add a3 to it and store in RP
	jmp	donext(PC)
*
	dcode	MP!,x,rpstor,mpstor
	move.l	initmp(PC),d5
	add.l	a3,d5	; get initmp and add a3 to it
	jmp	donext(PC)
*
	dcode	MP@,x,mpstor,mpfet
	move.l	d5,d0
	sub.l	a3,d0
	pushD0
	jmp	donext(PC)
*
	dcode	THEPORT,x,mpfet,port_
	move.l	(a5),a0	; Point to QD globals
	move.l	(a0),d0	; point to current grafport
	sub.l	a3,d0
	pushd0
	jmp	donext(PC)
*
	dcode	(LCWORD),x,port_,lcword	; doesn't map to upper ca
	popd0		; d0=len to next word
	lea	in9(PC),a0
	add.l	d0,(a0)	; bump IN
	popd0		; d0=offs to end of parsed word
	popd1		; d1=offs to beg of parsed word
	sub.w	d1,d0	; d0=len this word
	lea	dp9(PC),a0
	movea.l	(a0),a0	; a0=relative DP
	adda.l	a3,a0	; a0=abs DP = HERE
	move.b	d0,(a0)	; store len
	move.b	#32,1(a0,d0.l)	; blank at end of word
	movea.l	(SP)+,a1	; addr of string
	adda.l	a3,a1
	adda.l	d1,a1	; a1=source address to move from
wMov	move.b	-1(a1,d0.w),0(a0,d0.w)	; copy the string
	subq.l	#1,d0
	bne.s	wMov
	jmp	donext(PC)
*
	dcode	(WORD),x,lcword,word_	; fast code for WORD
	popd0		; d0=len to next word
	lea	in9(PC),a0
	add.l	d0,(a0)	; bump IN
	popd0		; d0=offs to end of parsed word
	popd1		; d1=offs to beg of parsed word
	sub.w	d1,d0	; d0=len this word
	lea	dp9(PC),a0
	movea.l	(a0),a0	; a0=relative DP
	adda.l	a3,a0	; a0=abs DP = HERE
	move.b	d0,(a0)	; store len
	move.b	#32,1(a0,d0.l)	; blank at end of word
	movea.l	(SP)+,a1	; addr of string
	adda.l	a3,a1
	adda.l	d1,a1	; a1=source address to move from
wordMov	move.b	-1(a1,d0.w),0(a0,d0.w)	; copy the string
	cmpi.b	#96,0(a0,d0.w)
	ble	wordmov1	; map to upper case
	cmpi.b	#123,0(a0,d0.w)
	bge	wordMov1
	subi.b	#32,0(a0,d0.w)
wordmov1	subq.l	#1,d0
	bne.s	wordMov
	jmp	donext(PC)
*
	dcode	(DODO),x,word_,dodo	; code for mcfa words
dodo1	move.w	-2(a3,d7.l),d0	; pickup len to child's pfa
	add.l	d0,d6	; advance wp
	move.l	d6,-(sp)	; push pfa for do> code
	suba.l	a3,a4
	move.l	a4,-(a6)	; save old IP on RP
	lea	10(a3,d7.l),a4	; point IP to threaded code
	jmp	donext(PC)
*
; this code gets compiled before each piece of DO.. code (10 bytes long)
	dcode	DOJMP,x,dodo,dojmp
	move.l	#(dodo1-origin),d0
	jmp	0(a3,d0.l)
*
; this code gets compiled into the front of each class definition
; and is pointed to by the cfa of all objects
	dcode	DOOBJ,x,dojmp,doobj
obcode	addq.l	#4,d6	; d6->pfa of object
dirObj	move.l	d6,-(SP)	; push obj addr
	jmp	donext(PC)
*
; this is the code pointed to by the cfa of all classes
	dcode	DOCLASS,x,doobj,dclass
	addq.l	#4,d6
	move.l	d6,-(SP)	; push ^class on stack
	move.l	#(bldvec-origin),d6	; d6 has cfa of BLDVEC
	move.l	0(a3,d6.l),d7	; d7 has code addr of BLDVEC
	jmp	0(a3,d7.l)	; do it
*
; runtime code for a message to a public object
	dcode	M0CFA,x,dclass,zcfa
	movea.l	d5,a2
	clr.l	d0
	clr.l	d4
	move.l	(SP)+,d3	; get obj addr in d3
	move.b	8(a3,d6.l),d0	; pickup #args for named stack
	beq	noArgs
	addq.l	#2,d6	; skip extra word for #args in method
	move.l	d0,d1	; save #args
	lsr.b	#4,d0	; get #temps nybble
	beq	noLocs	; no local vars
	move.l	d0,d4	; accum total #cells in d4
	lsl.b	#2,d0	; compute #bytes = cells*4
	suba.l	d0,a2	; allocate temp space
noLocs	andi.b	#$0f,d1	; low nybble has #input parms
	beq	noIns	; no input parms
	add.l	d1,d4
someArgs	move.l	(SP)+,-(a2)	; pop data stack to methods stack
	subq.w	#1,d1
	bne.s	someArgs	; transfer all args from data stack
noIns	move.l	d4,d0
noArgs	move.l	d0,-(a2)	; push #args to methods stack
	move.l	d3,-(a2)	; d3 has base address of local data
	move.l	a2,d5
	suba.l	a3,a4	; Perform colcode
	move.l	a4,-(a6)
	addq.l	#8,d6
	lea	0(a3,d6.l),a4
	jmp	donext(PC)
*
; runtime code for a message to a private ivar
	dcode	M1CFA,x,zcfa,onecfa
	move.l	d5,a2
	clr.l	d0
	clr.l	d4
	move.w	(a4)+,d0	; get offset to ivar
	bge	notSelf	; if negative, this is a Self reference
	clr.l	d0	; if self, preserve base addr
notSelf	move.l	(a2),d2	; get base address
	add.l	d0,d2	; add offset to base address
	clr.w	d0
	move.b	4(a3,d6.l),d0	; pickup #args for named stack
	beq	noArgs1
	addq.l	#2,d6	; skip extra word for #args in method
	move.l	d0,d1	; save #args
	lsr.b	#4,d0	; get #temps nybble
	beq	nolocs1
	move.l	D0,D4	; total #cells
	lsl.b	#2,d0	; compute #bytes = cells*4
	suba.l	d0,a2	; allocate temp space
noLocs1	andi.b	#$0f,d1	; low nybble has #input parms
	beq	noins1
	add.l	d1,d4	; save #input parms
args1	move.l	(SP)+,-(a2)	; pop data stack to methods stack
	subq.w	#1,d1
	bne.s	args1	; transfer all args from data stack
noins1	move.l	d4,d0
noArgs1	move.l	d0,-(a2)	; push #args to methods stack
	move.l	d2,-(a2)	; push offset+base to mstack
mNest	move.l	a2,d5
	suba.l	a3,a4	; do colcode nest
	move.l	a4,-(a6)
	addq.l	#4,d6
	lea	0(a3,d6.l),a4
	jmp	donext(PC)
*
	dcode	(;M),x,onecfa,semim_	; this is the ;m definition
	addq.l	#8,d5	; pop two entries from mstack
	movea.l	d5,a2
	move.l	-4(a2),d0	; look at #args
	beq	noPop
	lsl.w	#2,d0	; setup to add #args*4
	adda.l	d0,a2	; pop #args
	move.l	a2,d5
noPop	move.l	(a6)+,d7
	lea	0(a3,d7.l),a4
	jmp	donext(PC)
*
	dcode	;S,x,semim_,semis	; this is the ;S definition
	move.l	(a6)+,d7
	lea	0(a3,d7.l),a4
	jmp	donext(PC)
*
	dcode	COLP,x,semis,pcolon	; named stack colon code
pcolcode	move.l	d5,a2
	clr.l	d0
	clr.l	d4
	move.b	4(a3,d6.l),d0	; pickup #args for named stack
	beq	noArgs3
	addq.l	#2,d6	; skip extra word for #args in method
	move.l	d0,d1	; save #args
	lsr.b	#4,d0	; get #temps nybble
	beq	noLocs3	; no local vars
	move.l	d0,d4	; accum total #cells in d4
	lsl.b	#2,d0	; compute #bytes = cells*4
	sub.l	d0,a2	; allocate temp space
NoLocs3	andi.b	#$0f,D1	; low nybble has #input parms
	beq	noIns3	; no input parms
	add.l	d1,d4
Args3	move.l	(SP)+,-(a2)	; pop data stack to methods stack
	subq.w	#1,d1
	bne.s	Args3	; transfer all args from data stack
noIns3	move.l	d4,d0
noArgs3	move.l	d0,-(a2)	; push #args to methods stack
	clr.l	-(a2)	; waste the objaddr cell
	move.l	a2,d5	;
	suba.l	a3,a4	; Perform colcode
	move.l	a4,-(a6)
	addq.l	#4,d6
	lea	0(a3,d6.l),a4
	jmp	donext(PC)
*
	dcode	(SEMIP),x,pcolon,semip	; named stack denester co
	addq.l	#8,d5	; pop two entries from mstack
	movea.l	d5,a2
	move.l	-4(a2),d0	; look at #args
	beq	noPops1
	lsl.w	#2,d0	; setup to add #args*4
	adda.l	d0,a2	; pop #args
	move.l	a2,d5
nopops1	move.l	(a6)+,d7
	lea	0(a3,d7.l),a4
	jmp	donext(PC)
*
	dcode	LEAVE,x,semip,leave
	move.l	(a6),4(a6)
	jmp	donext(PC)
*
	dcode	>R,x,leave,toR
	move.l	(SP)+,-(a6)
	jmp	donext(PC)
*
	dcode	R>,x,toR,rFrom
	move.l	(a6)+,-(SP)
	jmp	donext(PC)
*
	dcode	R,x,rFrom,r
	move.l	(a6),-(SP)
	jmp	donext(PC)
*
	dcode	PUSHM,x,r,mpush
	exg	d5,a2
	move.l	(SP)+,-(a2)
	exg	d5,a2
	jmp	donext(PC)
*
	dcode	POPM,x,mpush,mpop
	exg	d5,a2
	move.l	(a2)+,-(SP)
	exg	d5,a2
	jmp	donext(PC)
*
	dcode	COPYM,x,mpop,mcopy
	move.l	d5,a2
	move.l	(a2),-(SP)
	jmp	donext(PC)
*
	dcode	EXGM,x,mcopy,mexg
	exg	d5,a2
	move.l	(SP),d0
	move.l	(a2),(SP)
	move.l	d0,(a2)
	jmp	donext(PC)
*
	dcode	DUPM,x,mexg,mdup
dupm	exg	d5,a2
	move.l	(a2),-(a2)
	exg	d5,a2
	jmp	donext(PC)
*
	dcode	ADDM,x,mdup,madd
	popd0
addmd0	exg	d5,a2	; copied this from nucleus--suspect!
	add.l	d0,(a2)
	exg	d5,a2
	jmp	donext(PC)
*
	dcode	DROPM,x,madd,mdrop
	exg	d5,a2	; *** popmd0
	move.l	(a2)+,d0
	exg	d5,a2
	jmp	donext(PC)
*
	dcode	MP0,x,mdrop,mp0	; mstack picks for named parms
	move.l	d5,a2
	move.l	8(a2),-(SP)	; push parm to data stack
	jmp	donext(PC)
*
	dcode	MP1,x,mp0,mp1	; mstack picks for named parms
	move.l	d5,a2
	move.l	12(a2),-(SP)	; push parm to data stack
	jmp	donext(PC)
*
	dcode	MP2,x,mp1,mp2	; mstack picks for named parms
	move.l	d5,a2
	move.l	16(a2),-(SP)	; push parm to data stack
	jmp	donext(PC)
*
	dcode	MP3,x,mp2,mp3	; mstack picks for named parms
	move.l	d5,a2
	move.l	20(a2),-(SP)	; push parm to data stack
	jmp	donext(PC)
*
	dcode	MP4,x,mp3,mp4	; mstack picks for named parms
	move.l	d5,a2
	move.l	24(a2),-(SP)	; push parm to data stack
	jmp	donext(PC)
*
	dcode	MP5,x,mp4,mp5	; mstack picks for named parms
	move.l	d5,a2
	move.l	28(a2),-(SP)	; push parm to data stack
	jmp	donext(PC)
*
	dcode	MS0,x,mp5,ms0	; mstack stores for named parms
	move.l	d5,a2
	move.l	(SP)+,8(a2)	; replace parm val with top of stack
	jmp	donext(PC)
*
	dcode	MS1,x,ms0,ms1	; mstack stores for named parms
	move.l	d5,a2
	move.l	(SP)+,12(a2)	; replace parm val with top of stack
	jmp	donext(PC)
*
	dcode	MS2,x,ms1,ms2	; mstack stores for named parms
	move.l	d5,a2
	move.l	(SP)+,16(a2)	; replace parm val with top of stack
	jmp	donext(PC)
*
	dcode	MS3,x,ms2,ms3	; mstack stores for named parms
	move.l	d5,a2
	move.l	(SP)+,20(a2)	; replace parm val with top of stack
	jmp	donext(PC)
*
	dcode	MS4,x,ms3,ms4	; mstack stores for named parms
	move.l	d5,a2
	move.l	(SP)+,24(a2)	; replace parm val with top of stack
	jmp	donext(PC)
*
	dcode	MS5,x,ms4,ms5	; mstack stores for named parms
	move.l	d5,a2
	move.l	(SP)+,28(a2)	; replace parm val with top of stack
	jmp	donext(PC)
*
	dcode	(++>),x,ms5,minc	; increment named parm
	move.l	d5,a2
	move.w	(a4)+,d0	; get element offset
	move.l	(sp)+,d1	; get increment value
	add.l	d1,0(a2,d0.w)	; increment the cell
	jmp	donext(PC)
*
	dcode	(EX>),x,minc,mdo	; execute a procedural arg
	move.l	d5,a2
	move.w	(a4)+,d0	; get offset to named parm
	move.l	0(a2,d0.w),d6	; get the cfa
	move.l	0(a3,d6.l),d7	; get the code
	jmp	0(a3,d7.l)
*
	dcode	+,x,mdo,plus
	popD0
	add.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	-,x,plus,subt
	popD0
	sub.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	MAX,x,subt,max
	popD0
	cmp.l	(SP),d0
	blt	maxq
	move.l	d0,(SP)
maxq	jmp	donext(PC)
*
	dcode	MIN,x,max,min
	popD0
	cmp.l	(SP),d0
	bgt	minq
	move.l	d0,(SP)
minq	jmp	donext(PC)
*
	dcode	NEGATE,x,min,minus
mins1	neg.l	(SP)
	jmp	donext(PC)
*
	dcode	DNEGATE,x,minus,dminus
dmins1	neg.l	4(SP)
	negx.l	(SP)
	jmp	donext(PC)
*
	dcode	CFA,x,dminus,cfa
	subq.l	#4,(SP)
	jmp	donext(PC)
*
	dcode	+-,x,cfa,plmin
	tst.l	(SP)+
	bmi.s	mins1
	jmp	donext(PC)
*
	dcode	ABS,x,plmin,abs
	tst.l	(SP)
	bmi.s	mins1
	jmp	donext(PC)
*
	dcode	DABS,x,abs,dabs
	tst.l	(SP)
	bmi.s	dmins1
	jmp	donext(PC)
*
	dcode	S->D,x,dabs,sToD
	moveq	#0,d0
	tst.l	(SP)
	bpl	GOHERE
	subq.l	#1,d0
GOHERE	pushd0
	jmp	donext(PC)
*
	dcode	OVER,x,sToD,over
	move.l	4(SP),-(SP)
	jmp	donext(PC)
*
	dcode	2OVER,x,over,over2
	move.l	12(SP),-(SP)
	move.l	12(SP),-(SP)
	jmp	donext(PC)
*
	dcode	DROP,x,over2,drop
	addq.l	#4,SP
	jmp	donext(PC)
*
	dcode	2DROP,x,drop,drop2
	addq.l	#8,SP
	jmp	donext(PC)
*
	dcode	SWAP,x,drop2,swap_
	popD0
	move.l	(SP),d1
	move.l	d0,(SP)
	pushD1
	jmp	donext(PC)
*
	dcode	2SWAP,x,swap_,swap2
	popD0
	popD1
	move.l	(SP)+,d3
	move.l	(SP),d4
	move.l	d1,(SP)
	move.l	d0,-(SP)
	move.l	d4,-(SP)
	move.l	d3,-(SP)
	jmp	donext(PC)
*
	dcode	DUP,x,swap2,dup
	move.l	(SP),-(SP)
	jmp	donext(PC)
*
	dcode	2DUP,x,dup,dup2
	move.l	4(SP),-(SP)
	move.l	4(SP),-(SP)
	jmp	donext(PC)
*
	dcode	-DUP,x,dup2,mindup
	tst.l	(SP)
	beq	ddup
	move.l	(SP),-(SP)
ddup	jmp	donext(PC)
*
	dcode	+!,x,mindup,plstor
	move.l	(SP)+,d7
	popD0
	add.l	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	TOGGLE,x,plstor,toggle
	popD0
	move.l	(SP)+,d7
	eor.b	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	W@,x,toggle,wfetch	; this is a 16-bit fetch
	clr.l	d0
	move.l	(SP),d7
	move.w	0(a3,d7.l),d0
	move.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	@,x,wfetch,fetch	; this is a 32-bit fetch
	move.l	(SP),d7
	move.l	0(a3,d7.l),(SP)
	jmp	donext(PC)
*
	dcode	C@,x,fetch,cfetch
	clr.l	d0
	move.l	(SP),d7
	move.b	0(a3,d7.l),d0
	move.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	MW@,x,cfetch,mwfetch	; 16-bit fetch from mstack addr
	move.l	d5,a2
	clr.l	d0
	move.l	(a2),d7
	move.w	0(a3,d7.l),d0
	ext.l	d0	; sign-extend
	move.l	d0,-(SP)
	jmp	donext(PC)
*
	dcode	M@,x,mwfetch,mfetch	; this is a 32-bit fetch
	move.l	d5,a2
	move.l	(a2),d7
	move.l	0(a3,d7.l),-(SP)
	jmp	donext(PC)
*
	dcode	2@,x,mfetch,fetch2	; ( double word fetch )
	move.l	(SP),d7
	lea	0(a3,d7.l),a0
	move.l	(a0)+,-(sp)
	move.l	(a0),4(SP)
	jmp	donext(PC)
*
	dcode	W!,x,fetch2,wstore	; 16-bit store
	move.l	(SP)+,d7	; address is relative to a3
	popD0		; d0 has value
	move.w	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	W+!,x,wstore,wpstore	; 16-bit plus store
	move.l	(SP)+,d7
	popD0
	add.w	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	!,x,wpstore,store	; 32-bit store
	move.l	(SP)+,d7	; address is relative to a3
	popD0		; d0 has value
	move.l	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	C!,x,store,cstore
	move.l	(SP)+,d7
	popD0
	move.b	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	C+!,x,cstore,cpstore	; 8 bit plus store
	move.l	(SP)+,d7
	popD0
	add.b	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	MW!,x,cpstore,mwstore	; 16-bit store to addr on mstack
	move.l	d5,a2
	move.l	(a2),d7	; address is relative to a3
	popD0		; d0 has value
	move.w	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	M!,x,mwstore,mstore	; 32-bit store to addr on mstack
	move.l	d5,a2
	move.l	(a2),d7	; address is relative to a3
	popD0		; d0 has value
	move.l	d0,0(a3,d7.l)
	jmp	donext(PC)
*
	dcode	2!,x,mstore,store2	; ( double word store )
	move.l	(SP)+,d7
	lea	0(a3,d7.l),a0
	move.l	(SP)+,(a0)+
	move.l	(SP)+,(a0)
	jmp	donext(PC)
*
	dcode	D+,x,store2,dplus	; 64-bit add
	popd0
	popd1
	move.l	(SP)+,d2
	move.l	(sp)+,d3
	add.l	d1,d3
	addx.l	d0,d2
	move.l	d3,-(SP)
	move.l	d2,-(SP)
	jmp	donext(PC)
*
	dcode	1+,x,dplus,plus1
	addq.l	#1,(SP)
	jmp	donext(PC)
*
	dcode	2+,x,plus1,plus2
	addq.l	#2,(SP)
	jmp	donext(PC)
*
	dcode	3+,x,plus2,plus3
	addq.l	#3,(SP)
	jmp	donext(PC)
*
	dcode	4+,x,plus3,plus4
	addq.l	#4,(SP)
	jmp	donext(PC)
*
	dcode	8+,x,plus4,plus8
	addq.l	#8,(SP)
	jmp	donext(PC)
*
	dcode	1-,x,plus8,min1
	subq.l	#1,(SP)
	jmp	donext(PC)
*
	dcode	2-,x,min1,min2
	subq.l	#2,(SP)
	jmp	donext(PC)
*
	dcode	4-,x,min2,min4
	subq.l	#4,(SP)
	jmp	donext(PC)
*
	dcode	8-,x,min4,min8
	subq.l	#8,(SP)
	jmp	donext(PC)
*
	dcode	2*,x,min8,times2
	move.l	(SP),d0
	asl.l	#1,d0
	move.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	4*,x,times2,times4
	move.l	(SP),d0
	asl.l	#2,d0
	move.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	2/,x,times4,xdiv2
	move.l	(SP),d0
	asr.l	#1,d0
	move.l	d0,(SP)
	jmp	donext(PC)
*
; ^elem expects base addr on mstack, and an index on pstack
	dcode	(^ELEM),x,xdiv2,pelem	; return address of array eleme
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.w	0(a3,d7.l),d1	; fetch width word from header
	mulu	2(SP),d1	; multiply index * width
	add.l	d1,d7	; add to base address
	addq.l	#4,d7	; skip the header
	move.l	d7,(SP)	; leave on data stack
	jmp	donext(PC)
*
	dcode	IDXBASE,x,pelem,idxbas	; idx addr of indexed object
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	addq.l	#4,d7	; skip the idx hdr
	move.l	d7,-(SP)	; leave the ^ixdata
	jmp	donext(PC)
*
	dcode	LIMIT,x,idxbas,limit	; limit of indexed object
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.w	2(a3,d7.l),-(SP)	; leave the limit
	clr.w	-(SP)
	jmp	donext(PC)
*
	dcode	RANGE?,x,limit,qrange	; index out of range?
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	clr.l	d0
	move.w	2(a3,d7.l),d0	; get the limit
	cmp.l	(SP),d0	; is limit > index?
	sle	d1	; true if out of range
	neg.b	d1	; forth boolean
	move.l	d1,-(SP)
	jmp	donext(PC)
*
	dcode	AT1,x,qrange,at1	; at opt for byte elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	add.l	(SP)+,d7	; add the index
	clr.l	d0
	move.b	4(a3,d7.l),d0	; fetch addr+4 (for idx hdr)
	move.l	d0,-(SP)
	jmp	donext(PC)
*
	dcode	AT2,x,at1,at2	; at opt for byte elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.l	(SP),d0	; get the index
	lsl.w	#1,d0	; index * 2
	add.l	d0,d7	; add the index
	move.w	4(a3,d7.l),d1	; fetch addr+4 (for idx hdr)
	ext.l	d1	; sign extend
	move.l	d1,(sp)
	jmp	donext(PC)
*
	dcode	AT4,x,at2,at4	; at opt for long elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.l	(SP)+,d0	; get the index
	lsl.w	#2,d0	; index * 4
	add.l	d0,d7	; add the index
	move.l	4(a3,d7.l),-(SP)	; fetch addr+4 (for idx hdr)
	jmp	donext(PC)
*
	dcode	TO1,x,at4,to1	; To opt for byte elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	add.l	(SP)+,d7	; add the index
	move.l	(SP)+,d0
	move.b	d0,4(a3,d7.l)	; store to addr+4 (for idx hdr)
	jmp	donext(PC)
*
	dcode	TO2,x,to1,to2	; To opt for byte elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.l	(SP)+,d0	; get the index
	lsl.w	#1,d0	; index * 2
	add.l	d0,d7	; add the index
	move.l	(sp)+,d1
	move.w	d1,4(a3,d7.l)	; store to addr+4 (for idx hdr)
	jmp	donext(PC)
*
	dcode	TO4,x,to2,to4	; to opt for long elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.l	(SP)+,d0	; get the index
	lsl.w	#2,d0	; index * 4
	add.l	d0,d7	; add the index
	move.l	(SP)+,4(a3,d7.l)	; store to addr+4 (for idx hdr)
	jmp	donext(PC)
*
	dcode	++4,x,to4,inc4	; inc opt for long elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.l	(SP)+,d0	; get the index
	lsl.w	#2,d0	; index * 4
	add.l	d0,d7	; add the index
	move.l	(SP)+,d1	; get increment
	add.l	d1,4(a3,d7.l)	; inc addr+4 (for idx hdr)
	jmp	donext(PC)
*
	dcode	++2,x,inc4,inc2	; inc opt for word elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.l	(SP)+,d0	; get the index
	lsl.w	#1,d0	; index * 4
	add.l	d0,d7	; add the index
	move.l	(SP)+,d1	; get increment
	add.w	d1,4(a3,d7.l)	; inc addr+4 (for idx hdr)
	jmp	donext(PC)
*
	dcode	++1,x,inc2,inc1	; inc opt for byte elements
	move.l	d5,a2	; pickup base address on mstack
	move.l	(a2),d7	; base of object in d7
	move.l	-4(a3,d7.l),d0	; d0 has ^class of object
	clr.l	d1
	move.w	18(a3,d0.l),d1	; d1 has dlen of object
	add.l	d1,d7	; d7 points to idx hdr
	move.l	(SP)+,d0	; get the index
	add.l	d0,d7	; add the index
	move.l	(SP)+,d1	; get increment
	add.b	d1,4(a3,d7.l)	; inc addr+4 (for idx hdr)
	jmp	donext(PC)
*
; fast left lshift ( val #shift -- val )
	dcode	<<,x,inc1,shfl
	popd0
	popd1
	lsl.l	d0,d1
	move.l	d1,-(SP)
	jmp	donext(PC)
*
; fast right lshift ( val #shift -- val )
	dcode	>>,x,shfl,shfr
	popd0
	popd1
	lsr.l	d0,d1
	move.l	d1,-(SP)
	jmp	donext(PC)
*
	dcode	(ABS),x,shfr,abs_	; leave absolute of mstack addr
	move.l	d5,a2
	move.l	(a2),d0
	add.l	a3,d0
	move.l	d0,-(SP)
	jmp	donext(PC)
*
	dcode	COUNT,x,abs_,count
	move.l	(SP),d0
	add.l	#1,(SP)
	clr.l	d1
	move.b	0(A3,d0.l),d1
	move.l	d1,-(SP)
	jmp	donext(PC)
*
	dcode	DEPTH,x,count,depth
	move.l	SP,d0
	sub.l	a3,d0
	move.l	#(s09-origin),d7
	sub.l	0(a3,d7.l),d0
	neg.l	d0
	asr.l	#2,d0
	pushD0
	jmp	donext(PC)
*
	dcode	FILL,x,depth,fil
	popD0
fill1	popD1
	move.l	(SP)+,d7
	lea	0(a3,d7.l),a0
fil1	subq.l	#1,d1
	bmi	fil2
	move.b	d0,(a0)+
	bra.s	fil1
fil2	jmp	donext(PC)
*
	dcode	ERASE,x,fil,era
	clr.l	d0
	bra.s	fill1
*
	dcode	BLANKS,x,era,blanks
	moveq	#$20,d0
	bra.s	fill1
*	
	dcode	+BASE,x,blanks,basadr
	move.l	(SP)+,d7
	pea	0(a3,d7.l)	; push absolute address = base+pa
	jmp	donext(PC)
*
	dcode	-BASE,x,basadr,minbas
	move.l	a3,d0
	sub.l	d0,(SP)
	jmp	donext(PC)
*
	dcode	ROT,x,minbas,rot
	popD0
	popD1
	move.l	(SP),d2
	move.l	d1,(SP)
	pushD0
	move.l	d2,-(SP)
	jmp	donext(PC)
*
	dcode	PICK,x,rot,pick
	move.l	(SP),d0
	asl.l	#2,d0	; index * 4
	move.L	0(SP,d0.w),(SP)
	jmp	donext(PC)
*
	dcode	RESET,x,pick,rset	; reboot the machine
	reset
*
	dcode	(FDOS),x,rset,fdos	; general file system trap call
	lea	fdtrap(PC),a0	; stack : (pblock trap --- result)
	clr.l	d0
	move.w	(SP)+,d0	; function selector
	move.w	(SP)+,(a0)	; move in trap#
	movea.l	(SP)+,a0	; file control block
	adda.l	a3,a0	; make it absolute
fdtrap	DC.W	0	; call Toolbox
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushd0
	jmp	donext(PC)
*
	dcode	(MAKE),x,fdos,make_
	move.l	(SP)+,a0	; parm block offset in a0
	add.l	a3,a0	; make it absolute
	_Hcreate		; call Toolbox
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushd0
	jmp	donext(PC)
*
	dcode	(OPEN),x,make_,open_
	popd0		; get access mode in d0
	move.l	(SP)+,a0	; parm block offset in a0
	add.l	a3,a0	; make it absolute
	move.b	d0,ioPermssn(a0)	; set i/o permission
	_Hopen		; open the file
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushd0
	jmp	donext(PC)
*
	dcode	(CLOSE),x,open_,close_
	move.l	(SP)+,a0	; parm block offset in a0
	add.l	a3,a0	; make it absolute
	_close		; call Toolbox CLOSE
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushd0
	jmp	donext(PC)
*
	dcode	(DELETE),x,close_,delet_
	move.l	(SP)+,a0	; parm block offset in a0
	add.l	a3,a0	; make it absolute
	_delete		; call Toolbox DELETE
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushd0
	jmp	donext(PC)
*
	dcode	(READ),x,delet_,read_
	popD0		; pop buffer address into d0
	add.l	a3,d0	; make it absolute
	popD1		; get count in d1
	move.l	(SP)+,a0	; parm block offset in a0
	add.l	a3,a0	; make it absolute
	move.l	d0,iobuffer(a0)	; store buffer pointer in parm block
	move.l	d1,ioReqCount(a0)	; store count in parm block
	_read		; call Toolbox read
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushd0
	jmp	donext(PC)
*
	dcode	(WRITE),x,read_,write_
	popD0		; pop buffer address into d0
	add.l	a3,d0	; make it absolute
	popD1		; get count in d1
	move.l	(SP)+,a0	; parm block offset in a0
	add.l	a3,a0	; make it absolute
	move.l	d0,iobuffer(a0)	; store buffer pointer in parm block
	move.l	d1,ioReqCount(a0)	; store count in parm block
	_write		; call Toolbox read
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushD0
	jmp	donext(PC)
*
	dcode	(LSEEK),x,write_,lseek
	popD0		; pickup position offset in D0
	popD1		; pickup positioning mode in D1
	move.l	(SP)+,a0	; pop pba
	add.l	a3,a0
	move.l	d0,ioPosOffset(a0)	; set offset in parm block
	move.w	d1,ioPosMode(a0)	; set mode in parm block
	_SetFPos
	move.w	ioResult(a0),d0	; leave result on stack
	ext.l	d0
	pushd0
	jmp	donext(PC)
*
; ------- (;CODE) is needed by the following words
	dcol	(;CODE),x,lseek,pscode
	cfas	rfrom,latest,pfa,cfa,store,semis
*
; ------- The following words are ;CODE type words
	dcol	CONSTANT,x,pscode,const
	cfas	kreate,comma
	scode		; points to (;CODE)
concode	addq.l	#4,d6	; runtime code for constant
	move.l	0(a3,d6.l),-(SP)
	jmp	donext(PC)
*
	dcol	:,I,const,colon	; this colon doesn't set Context
	cfas	qexec,stcsp	; to Current.
	cfas	kreate,rbrak
	scode
colcode	suba.l	a3,a4	; convert absolute address to offset
	move.l	a4,-(a6)	; push current IP to Return stack
	addq.l	#4,d6	; advance WP to pfa of word being def.
	lea	0(a3,d6.l),a4	; get absolute addr in A4
	jmp	donext(PC)
*
	dcol	DOES>,x,colon,does
	cfas	rfrom,latest,pfa
	DATA	store-origin
	scode
doescode	addq.l	#4,d6
	suba.l	a3,a4
	move.l	a4,-(a6)
	move.l	0(a3,d6.l),d7
	lea	0(a3,d7.l),a4
	addq.l	#4,d6
	move.l	d6,-(SP)
	jmp	donext(PC)
*
	dcol	VARIABLE,x,does,varb
	cfas	const
	scode
varcode	addq.l	#4,d6
	move.l	d6,-(SP)
	jmp	donext(PC)
*
	dcode	OBJMP,x,varb,objmp
	move.l	#(obcode-origin),d0	; get addr of object code
	jmp	0(a3,d0.l)	; obj puts its addr on stack
*
	dcol	(AB"),x,objmp,abq_	; abort" runtime word
	cfas	mindup
	eif.	abq11
	cfas	cr,lit,10+origin,beep,here,count,type
	cfas	lit,63+origin,emit,space,R,count,type,abort
	else.	abq11
	cfas	rfrom,count,plus,aline,tor
	ethen.	abq11
	cfas	semis
*
	dcol	PREFIX,x,abq_,prefix	; prefix builder for mcfa
	cfas	builds,times4,wcomma,immed
	cfas	does
dopref	cfas	fetpfa
	cfas	cfa,over,wfetch,plus
	cfas	swap_,min4,over,fetch,lit,6+origin,subt
	cfas	fetch,subt,abq_
	STR	"invalid prefix "
	cfas	state
	if.	pre11
	cfas	comma,semis
	then.	pre11
	cfas	exec,semis
*
; execute 1cfa of object vector ivar
	dcode	X1CFA,x,prefix,x1cfa
	move.l	d5,a2	; 1cfa is the fetch/deferred exec routine
	clr.l	d6
	move.w	(a4)+,d6	; get offset to ivar
	add.l	(a2),d6	; add base addr to get 1cfa addr in WP
	move.l	0(a3,d6.l),d7	; get code addr in d7
	jmp	0(a3,d7.l)
*
	dcol	VOCABULARY,x,x1cfa,vocab
	cfas	builds
	mlit	$8120
	cfas	wcomma,currnt,min2,comma,here,vocl,comma
	cfas	vocl2,does
dovocab	cfas	plus2,contxt2,semis
*
; define prefixes for 3cfa variables,vects
	ddoes	PUT,I,vocab,preput,dopref	; 2cfa for all
	DC.W	8
	ddoes	PUTDEF,I,preput,prputd,dopref	; 1cfa for sysVe
	DC.W	4
; define code handlers for 3cfa variables,vects
	DATA	0	; fetch code for sysvect
	DC.W	8	; len to vect's pfa from 1cfa
dofetchv	addq.l	#8,d6	; advance wp to pfa
	move.l	0(a3,d6.l),-(SP)	; get contents of pfa
	jmp	donext(PC)
*
	DATA	preput+4-origin	; store code
	DC.W	4	; len to vect's pfa from 1cfa
dostore	addq.l	#4,d6	; advance wp to pfa
	move.l	(SP)+,0(a3,d6.l)	; get contents of pfa
	jmp	donext(PC)
*
	DATA	0	; increment code
	DC.W	8	; len to vect's pfa from 1cfa
doincr	addq.l	#8,d6	; advance wp to pfa
	popd0
	add.l	d0,0(a3,d6.l)	; increment contents of pfa
	jmp	donext(PC)
*
	DC.W	12
doexec	add.l	#12,d6
	move.l	0(a3,d6.l),d6	; get address to execute
	move.l	0(a3,d6.l),d7	; get contents of CFA
	jmp	0(a3,d7.l)	; execute the code
	DC.W	12	; execute a system vector table entry
dosexec	add.l	#12,d6
	move.l	userdp(PC),d0	; rel base of system vector table
	add.l	0(a3,d6.l),d0	; add offset into table
	move.l	0(a3,d0.l),d1	; get vector contents
	beq	dodeflt	; if 0, exec default
	move.l	d1,d6
	bra.s	sexec
dodeflt	move.l	4(a3,d6.l),d6	; get default cfa to execute
sexec	move.l	0(a3,d6.l),d7	; get contents of CFA
	jmp	0(a3,d7.l)	; execute the code
*
	DATA	prputd+4-origin
	DC.W	8	; set offset, default for system vector
doputdef	addq.l	#8,d6
	move.l	(SP)+,0(a3,d6.l)	; set the offset
	move.l	(SP)+,4(a3,d6.l)	; set the default
	jmp	donext(PC)
*
	DATA	preput+4-origin
	DC.W	4	; set sys vector table entry for this vect
doputsv	addq.l	#4,d6
	move.l	userdp(PC),d0
	add.l	0(a3,d6.l),d0	; add the offset
	move.l	(SP)+,0(a3,d0.l)	; store the vector
	jmp	donext(PC)
*
	DC.W	12	; len to value's pfa from 1cfa
dofetch	add.l	#12,d6	; advance wp to pfa
	move.l	0(a3,d6.l),-(SP)	; get contents of pfa
	jmp	donext(PC)
*
	dcol	",",x,prputd,comma	; begin comman dict entry
	cfas	here,store,pfour,allot,semis
*
	dcol	"W,",x,comma,wcomma	; begin Wcomma dict entry
	cfas	here,wstore,lit,2+origin,allot,semis
*
	dcol	"C,",x,wcomma,ccomma	; begin C, dict entry
	cfas	here,cstore,pone,allot,semis
*
	dcol	@PFA,x,ccomma,fetpfa
	cfas	mfind,zequ,abq_
	STR	"not found  "
	cfas	drop,semis
*
	dcol	LFA,x,fetpfa,lfa
	mlit	8
	cfas	subt,semis
*
	dcol	NFA,x,lfa,nfa
	mlit	9
	cfas	subt
	mlit	-1
	cfas	traver,semis
*
	dcol	PFA,x,nfa,pfa
	mlit	1
	cfas	traver,lit,9+origin,plus,semis
*
	dcol	ALIGN,x,pfa,aline
	cfas	dup
	mlit	1
	cfas	and_,plus,semis
*
	dcol	DECIMAL,x,aline,decim
	mlit	$0a
	cfas	base2,semis
*
	dcol	HEX,x,decim,hex
	mlit	$10
	cfas	base2,semis
*
	dcol	(."),x,hex,dotq_
	cfas	r,count,dup,plus1,aline,rfrom,plus,toR,type
	cfas	semis
*
	dcol	PAD,x,dotq_,pad
	mlit	padbuf-origin
	cfas	semis
*
	dcol	#>,x,pad,enum
	cfas	drop2,hld,pad,over,subt,semis
*
	dcol	HOLD,x,enum,hold
	DATA	pmone-origin
	cfas	hld1,hld,cstore,semis
*
	dcol	SIGN,x,hold,sign
	cfas	rot,zless
	if.	Z3
	mlit	$2d
	cfas	hold
	then.	Z3
	cfas	semis
*
	dcol	#,x,sign,sharp
	cfas	base,msmod,rot
	mlit	9
	cfas	over,less
	if.	Z4
	mlit	7
	cfas	plus
	then.	Z4
	mlit	$30
	cfas	plus,hold,semis
*
	dcol	#S,x,sharp,sharps
	begin.	Z5
	cfas	sharp,dup2,or_,zequ
	until.	Z5
	cfas	semis
*
	dcol	<#,x,sharps,snum
	cfas	pad,hld2,semis
*
	dcol	D.R,x,snum,ddotr
	cfas	toR,swap_,over,dabs,snum,sharps,sign,enum,rfrom
	cfas	over,subt,spaces,type,semis
*
	dcol	D.,x,ddotr,ddot
	mlit	0
	cfas	ddotr,space,semis
*
	dcol	.,x,ddot,dot
	cfas	sToD,ddot,semis
*
	dcol	U.,x,dot,udot
	mlit	0
	cfas	ddot,semis
*
	dcol	.R,x,udot,dotR
	cfas	toR,sToD,rfrom,ddotr,semis
*
	dcol	?,x,dotR,quest
	cfas	fetch,dot,semis
*
	dcol	SPACE,x,quest,space
	cfas	bl,emit,semis
*
	dcol	SPACES,x,space,spaces
	mlit	0
	do.	Z7
	cfas	bl,emit
	loop.	Z7
	cfas	semis
*
	dcol	-TRAILING,x,spaces,mtrail
	cfas	dup
	mlit	0
	do.	Z8
	cfas	over,over,plus,min1,cfetch,bl,subt
	eif.	Z10
	cfas	leave
	else.	Z10
	cfas	min1
	ethen.	Z10
	loop.	Z8
	cfas	semis
*
	dcol	N>COUNT,x,mtrail,ncount
	cfas	count
	mlit	$1f
	cfas	and_,semis
*
	dcol	ID.,x,ncount,iddot
	cfas	ncount,type,space,semis
*
	dcol	EMIT,x,iddot,emit
	cfas	dup,emitvec,pemitv,pone	 ; send the char via Quickdraw
	cfas	out1,semis
*
	dcol	TYPE,x,emit,type
	cfas	dup,out1,dup2,typevec,ptypev,semis
	dcol	CR,x,type,cr
	cfas	crvec,pcrvec,semis
*
	dcol	CONTBOT,x,cr,contbot
	cfas	port_,lit,windowsize+origin,plus,plus4
	cfas	wfetch,semis
*
	dcol	CONTTOP,x,contbot,conttop
	cfas	port_,lit,windowsize+origin,plus
	cfas	wfetch,semis
*
	dcol	?LEAD,x,conttop,qlead	; return proper leading for fo
	cfas	port_,lit,txsize+origin,plus,wfetch
	cfas	lit,120+origin,star,lit,50+origin,plus	; Increase 120 f
	cfas	lit,100+origin,slash,semis
*
	dcol	?LINES,x,qlead,qlines	; number of even lines in port
	cfas	qlead,contbot,conttop	; bottom-top of content rgn
	cfas	subt,over,plus1,subt	; minus ?LEAD+1
	cfas	swap_,slash,semis	; divided by ?LEAD
*
	dcol	BOTTOM,x,qlines,scrbot	; coordinate of screen bottom
	cfas	conttop,plus4,qlead,qlines,star,plus
	cfas	semis
*
	dcol	(CR),x,scrbot,cr_	; simulate a CR in Quickdraw
	cfas	dotcur,fetxy,swap_,drop,lit,8+origin,swap_
	cfas	dup,scrbot,grt
	eif.	x27
	cfas	pzer,qlead,minus,scroll,gotoxy
	else.	x27
	cfas	qlead,plus
	cfas	gotoxy
	ethen.	x27
	cfas	dotcur,semis
*
	dcol	(BS),x,cr_,bs_
	cfas	dotcur,fetxy,swap_,lit,6+origin,subt,lit,8+origin,max
	cfas	swap_,dup2,gotoxy,bl,emit,gotoxy,dotcur,semis
*
	dcol	?TERMINAL,x,bs_,qterm
	cfas	lit,$28+origin,qevt,semis
	dcol	(KEY),x,qterm,key_
	mlit	$2A		; kbd and mouse events
	cfas	getevt,lit,2+origin,grt
	eif.	Z100
	cfas	ftemsg,lit,$00ff+origin,and_
	else.	Z100
	cfas	pmone
	ethen.	Z100
	cfas	semis
*
	dcol	(DKEY),x,key_,dkey_
	cfas	ufcb,pone,lit,ftwork	; read 1 char from disk
	cfas	read_,dup,dkerr2
	eif.	y10
	cfas	keystor,pone,curs_2	; restore to terminal if err
	cfas	lit,13+origin
	else.	y10
	cfas	lit,ftwork,cfetch	; leav char on stack
	ethen.	y10
	cfas	qpause,semis
*
	dcol	KEY!,x,dkey_,keystor	; reset KEY to keyboard
	cfas	lit,key_,keyvec2,semis
*
	dcol	KEY,x,keystor,key
	cfas	keyvec,semis	; vectored key
*
	dcol	<",x,key,diskin	; set to disk key inpu
	cfas	ufcb,close_,dot	; close the oldfile
	cfas	lit,useFcb,lit,80+origin,era,pzer,curs_2
	cfas	lit,34+origin,word,here,dup,cfetch,plus1
	cfas	lit,useFname,swap_,cmove
	cfas	lit,useFname,basadr,lit,useFcb,sflptr
	cfas	ufcb,pone,open_,dot
	cfas	cr,lit,dkey_,keyvec2,semis
*
; ------------ Disk words for FORTH screen handling
	dcol	!FPTR,x,diskin,sflptr	; ( ^fname pblock -- )
	cfas	lit,18+origin,plus,store,semis
*
	dcol	?COMP,x,sflptr,qcomp
	cfas	state,zequ,abq_
	STR	"compilation only "
	cfas	semis
*
	dcol	?DP,x,qcomp,qdp	; dp grown into heap?
	cfas	room,pone,less,abq_
	STR	" out of room "
	cfas	semis
*
	dcol	?STACK,x,qdp,qstack
	cfas	spfet,s0,swap_,uless
	cfas	abq_
	STR	"empty stack  "
	cfas	semis
*
	dcol	?EXEC,x,qstack,qexec
	cfas	state,cstate,or_,abq_	; err if class or forth compile
	STR	"run state only "
	cfas	semis
*
	dcol	?PAIRS,x,qexec,qpairs
	cfas	subt,abq_
	STR	"unpaired conditionals  "
	cfas	semis
*
	dcol	?DECIMAL,x,qpairs,qdec
	cfas	base,lit,$0a+origin,subt,abq_
	STR	"must be decimal"
	cfas	semis
*
	dcol	?CSP,x,qdec,qcsp
	cfas	spfet,csp,subt,abq_
	STR	"definition not finished  "
	cfas	semis
*
	dcol	(NUMBER),x,qcsp,num_
	begin.	Z27
	cfas	plus1,dup,tor,cfetch,base,digit
	while.	Z27
	cfas	swap_,base,ustar,drop,rot,base
	cfas	ustar,dplus,dpl,plus1
	if.	Z28
	cfas	pone,dpl1
	then.	Z28
	cfas	rfrom
	repeat.	Z27
	cfas	rfrom,semis
*
	dcol	?NUM,x,num_,qnum	; ( addr -- d t OR f )
	mlit	0
	mlit	0
	cfas	rot,dup,plus1,cfetch
	mlit	$2d
	cfas	equals,dup,tor,plus
	mlit	-1
	begin.	Z30
	cfas	dpl2,num_,dup,cfetch,bl,subt
	while.	Z30
	cfas	dup,cfetch,lit,$2e+origin,subt
	if.	zz177
	cfas	rfrom,drop,drop,drop2,pzer,semis
	then.	zz177
	mlit	0
	repeat.	Z30
	cfas	drop,rfrom
	if.	Z31
	cfas	dminus
	then.	Z31
	cfas	pone,semis
*
	dcol	NUMBER,x,qnum,number	; ( addr -- d )
	cfas	qnum,zequ,abq_
	STR	"not found  "
	cfas	semis
*
	dcol	LITERAL,I,number,liter
	cfas	state
	if.	Z32
	cfas	dup,lit
	DATA	$10000
	cfas	less,over,zless,zequ,and_
	eif.	zz39
	cfas	comp,wlit,wcomma
	else.	zz39
	cfas	comp,lit,comma	; builds word lit if n>=0 and n<$10000
	ethen.	zz39
	then.	Z32
	cfas	semis
*
	dcol	EXPECT,x,liter,expect
	cfas	over,plus,over
	do.	Z33
	cfas	key,dup,lit,8+origin,equals	; bs ?
	eif.	Z34
	cfas	drop,dup,i,equals,dup,rfrom,min2,plus,tor
	eif.	Z35
	cfas	lit,10+origin,beep
	else.	Z35
	cfas	bs_
	ethen.	Z35
	cfas	pzer
	else.	Z34
	cfas	dup,zequ
	if.	y118
	cfas	drop,lit,32+origin	; map null to space
	then.	y118
	cfas	dup,lit,$0d+origin,equals
	eif.	Z36
	cfas	leave,drop,pzer,pzer,cr
	else.	Z36
	cfas	dup
	ethen.	Z36
	cfas	r,cstore,pzer,r,plus1,cstore
	ethen.	Z34
	cfas	echovec
	loop.	Z33
	cfas	drop,semis
*
	dcol	WORD,x,expect,word
	cfas	tib
	cfas	in,plus,swap_,enclos
	cfas	word_,semis
*
	dcol	WORD",x,word,wordq	; lower-case version of word
	cfas	tib,in,plus,lit,34+origin,enclos
	cfas	lcword,here,semis
	dcol	FIND,x,wordq,mfind
	cfas	bl,word,ufind,dup,zequ
	if.	w72
	cfas	drop,here,contxt,fetch
	cfas	find_,dup,zequ
	if.	Z38
	cfas	contxt,currnt,subt
	if.	Z40
	cfas	drop,here,latest,find_
	then.	Z40
	then.	Z38
	then.	w72
	cfas	semis
*
	ADJST		; X - null word
lkx	DC.B	$C1
	DC.B	$00
	DATA	lkmfind-origin
	DATA	colcode-origin	; not Fig standard -
	cfas	rfrom,drop	; note: doesn't support Forth screens
	cfas	semis
*
	dcol	"S,",x,x,scomma	; begin S, dict entry
	cfas	here,dup,cfetch,plus1,aline
	cfas	allot,dup,rot,toggle,semis
*
	dcol	(CREATE),x,scomma,creat_
	cfas	here,pone,and_
	if.	Z410
	cfas	pzer,ccomma
	then.	Z410
	cfas	mfind
	if.	Z420
	cfas	drop,nfa,iddot,dotq_
	STR	"is redefined "
	cfas	cr
	then.	Z420
	cfas	lit,$80+origin,scomma
	cfas	latest,comma,currnt
	cfas	store,here,plus4,comma,semis
*
	dcol	(INTRP),x,creat_,intrp_
	begin.	Z43
	cfas	mfind
	eif.	Z44
	cfas	state,less
	eif.	Z45
	cfas	cfa,comma
	else.	Z45
	cfas	cfa,exec
	ethen.	Z45
	else.	Z44
	cfas	here,number,dpl,plus1
	eif.	Z46
	cfas	dliter
	else.	Z46
	cfas	drop,liter
	ethen.	Z46
	ethen.	Z44
	cfas	qdp,qstack
	again.	Z43
	cfas	semis
*
	dcol	!CSP,x,intrp_,stcsp
	cfas	spfet,csp2,semis
*
	dcol	QUERY,x,stcsp,query
	cfas	tib,lit,$99+origin
	cfas	expvec,pzer,in2,semis
	dcol	<[,I,query,lbrak
	mlit	0
	cfas	state2,semis
	dcol	]>,x,lbrak,rbrak
	mlit	$c0
	cfas	state2,semis
*
	dcol	DEFINITIONS,x,rbrak,defs
	cfas	contxt,currnt2,semis
*
	dcol	<BUILDS,x,defs,builds
	mlit	0
	cfas	const,semis
*
	dcol	OK,x,builds,ok
	cfas	depth,ptwo,dotr,base,dup
	cfas	lit,10+origin,equals
	eif.	xx11
	cfas	lit,45+origin,emit
	else.	xx11
	cfas	dup,lit,16+origin,equals
	eif.	xx12
	cfas	lit,36+origin,emit
	else.	xx12
	cfas	lit,63+origin,emit
	ethen.	xx12
	ethen.	xx11
	cfas	drop,lit,62+origin,emit
	cfas	semis
*
	dcode	Q,x,ok,q_
	clr.w	-(sp)
	_hilitemenu
	jmp	donext(PC)
*
	dcol	QUIT,x,ok,quit
	cfas	pzer,in2
	cfas	lbrak,quvec,q_
	cfas	cr,ok
	begin.	Z48
	cfas	qdp,rpstor,query,interp,state,zequ
	if.	Z50
	cfas	ok
	then.	Z50
	again.	Z48
	cfas	semis
*
	dcol	BACK,x,quit,back
	cfas	here,subt,comma,semis
*
	dcol	FWD,x,back,fwd	; fill in fwd branch
	cfas	here,over,subt,swap_,store,semis
*
	dcol	BEGIN,I,fwd,begin
	cfas	qcomp,here,pone,semis
*
	dcol	THEN,I,begin,then
	cfas	qcomp,lit,2+origin,qpairs,fwd,semis
*
	dcol	DO,I,then,do	; compiles fwd branch for smart exit
	cfas	comp,do_,here,pzer,comma,lit,3+origin,semis
*
	dcol	LOOP,I,do,loop
	cfas	lit,3+origin,qpairs,comp,loop_,dup,plus4,back
	cfas	fwd,semis
*
	dcol	+LOOP,I,loop,ploop
	cfas	lit,3+origin,qpairs,comp,ploop_,dup,plus4,back
	cfas	fwd,semis
*
	dcol	COMPILE,x,ploop,comp
	cfas	qcomp,rfrom,dup,plus4
	cfas	tor,fetch,comma,semis
	dcol	[COMPILE],I,comp,bcomp
	cfas	fetpfa,cfa,comma,semis
*
	dcol	DLITERAL,I,bcomp,dliter
	cfas	state
	if.	Z51
	cfas	swap_,liter,liter
	then.	Z51
	cfas	semis
*
	dcol	UNTIL,I,dliter,until
	cfas	pone,qpairs,comp,bran0,back,semis
*
	dcol	AGAIN,I,until,again
	cfas	pone,qpairs,comp,bran,back,semis
*
	dcol	REPEAT,I,again,repeat
	cfas	tor,tor,again,rfrom,rfrom,min2
	cfas	then,semis
	dcol	IF,I,repeat,xif
	cfas	comp,bran0,here,pzer,comma,lit,2+origin,semis
*
	dcol	ELSE,I,xif,xelse
	cfas	lit,2+origin,qpairs,comp,bran,here,pzer,comma
	cfas	swap_,lit,2+origin,then,lit,2+origin,semis
*
	dcol	WHILE,I,xelse,while
	cfas	xif,plus2,semis
*
	dcol	EXIT,I,while,exit
	cfas	latest,pfa,cfa,fetch	; is this a pcolon def?
	cfas	lit,pcolcode,equals
	eif.	se10
	cfas	comp,semip	; yes, put in parm denester
	else.	se10
	cfas	comp,semis
	ethen.	se10
	cfas	semis
*
	dcol	;,I,exit,semi	; immediate - semicolon def
	cfas	qcsp,exit,lbrak,semis
*
	dcol	.",I,semi,dotq
	cfas	state
	eif.	Z52
	cfas	comp,dotq_
	cfas	wordq	; lower-case word
	cfas	cfetch,plus1,aline,allot
	else.	Z52
	cfas	wordq,count,type
	ethen.	Z52
	cfas	semis
*
	dcol	IMMEDIATE,x,dotq,immed
	cfas	latest,lit,$40+origin,toggle,semis
*
	dcol	LATEST,x,immed,latest
	cfas	currnt,fetch,semis
	dcol	(,I,latest,lparen
	cfas	lit,$29+origin,word,semis
*
	ADJST	
lktick	DC.B	$c1	; tick
	DC.B	$27
	DATA	lklparen-origin
tick	DATA	colcode-origin
	cfas	fetpfa,liter,semis
*
	dcol	FORGET,x,tick,forget
	cfas	defs	; set current to context
	cfas	tick,dup,fence,uless,abq_
	STR	"in protected dictionary  "
	cfas	dup,nfa,dp2,lfa,fetch,currnt
	cfas	store,semis
*
	dcol	ROOM,x,forget,room	; leave dict space left
	cfas	msiz,fetch,dp,bdp,fetch
	cfas	subt,subt,semis
*
	dcol	GREET,x,room,greet
	cfas	cls
	mlit	hello-origin
	cfas	count,type,cr
	mlit	bytesleft-origin
	cfas	count,type
	cfas	room,dot,cr,semis
*
	dcol	COLD,x,greet,xcold
	cfas	lit,aregn,fetch,zequ
	if.	w59
	cfas	intool	; only if we haven't gotten heap already
	then.	w59
	cfas	lit,inits0,fetch,s02,lit,initr0,fetch,r02
	cfas	lit,initfenc,fetch,fence2,lit,initvocl,fetch,vocl2
	cfas	lit,initdp,fetch,dp2,lit,initmp,fetch,m02
	cfas	lit,initlast,fetch,lit,forth_
	cfas	lit,$0a+origin,plus,store,decim,spstor,mpstor
	cfas	forth_,defs,pzer,warn2,objini,greet,quit,semis
*
	dcol	.PAUSE,x,xcold,dpause
	cfas	lit,pausemsg,count,type,semis
*
	dcol	?PAUSE,x,dpause,qpause	; check if user wants to stop
	cfas	qterm
	if.	w43
	cfas	key_,drop,cr,dpause
	cfas	key_,cr,lit,0+origin,out2,lit,32+origin,grt
	if.	w44
	cfas	abort
	then.	w44
	then.	w43
	cfas	semis
*
	dcol	ABORT,x,qpause,abort
	cfas	cr
	cfas	spstor,mpstor,lit,key_,keyvec2,decim
	cfas	pone,curs_2,qstack,lbrak,forth_
	cfas	defs,abvec
	cfas	lit,$a850+origin,trap_	; initCursor
	cfas	quit,semis
*
	ddoes	YERK,x,abort,forth_,dovocab	; FORTH vocabulary
	DC.W	$8120
vlf	DATA	lastdef-origin
	DATA	0
*
	dcol	.VAL,x,forth_,dotval
	cfas	dotr,lit,2+origin,spaces,semis
*
	dcol	?CFA,x,dotval,qcfa
	cfas	dup,plus4,nfa,ncount
	cfas	tor,r,plus,plus4,aline
	cfas	over,equals,rfrom,land_,semis
*
	dcol	(.STACK),x,qcfa,dstak_
	cfas	base,lit,ftwork1,store,dup2,grt	; preserve current base
	eif.	z61
	do.	z62
	cfas	cr,ifetch,dup,decim
	cfas	lit,8+origin,dotval,dup,hex,lit,36+origin,emit
	cfas	pzer,lit,6+origin,ddotr
	cfas	lit,3+origin,spaces,aline,min4,plus1,false
	eif.	z63
	cfas	plus4,nfa,iddot
	else.	z63
	cfas	drop
	ethen.	z63
	cfas	pfour
	ploop.	z62
	else.	z61
	cfas	lit,emptymsg,count,type,less
	cfas	abq_
	STR	"Stack Underflow  "
	ethen.	z61
	cfas	lit,ftwork1,fetch,base2,cr	restore base
	cfas	semis
*
Lastdef	dcol	.S,x,dstak_,dots
	cfas	spfet,s0,swap_,lit,dsmsg
	cfas	count,type,dstak_,r0,rpfet,lit,rsmsg
	cfas	count,type,dstak_,m0,mpfet,lit,msmsg
	cfas	count,type,dstak_
	cfas	semis
*
nextdef	EQU	*
	ENDR
*
	SEG	0,32,VAR.LEN,$20
SEG0
SEG_1	JP	origin,1
END_1
END0
	ENDR
*
*	END
	RSRC	YERK,0
	STR	"Yerk Version 3.3"
	ENDR
*
	RSRC	FREF,128,32
	ASC	'APPL'
	DATA	/0
	STR	""
	ENDR
*
	RSRC	FREF,129,32
	ASC	'COM '
	DATA	/1
	STR	""
	ENDR
*
	RSRC	FREF,130,32
	ASC 'USER'
	DATA /2
	STR	""
	ENDR
*
	RSRC	FREF,131,32
	ASC	'BIN '
	DATA /3
	STR	""
	ENDR
*
	RSRC	FREF,132,32
	ASC	'TEXT'
	DATA /4
	STR	""
	ENDR
*
	RSRC	ICN#,128,32
	HEX	71c0.0000.cb20.0000
	HEX	c620.0000.6040.0000
	HEX	3080.0000.1900.1f80
	HEX	1900.2040.197e.4020
	HEX	1981.9810.1e8e.e408
	HEX	0ccf.3f87.3069.1803
	HEX	c864.8003.c864.4003
	HEX	c8c8.f003.c99f.8ff3
	HEX	c981.990f.c9ff.9903
	HEX	c8fd.8200.c801.8400
	HEX	c801.8200.c801.91ce
	HEX	c801.9939.c801.9f32
	HEX	c801.d724.c800.e308
	HEX	c800.0304.cfff.e322
	HEX	c000.1331.c000.1339
	HEX	ffff.e3ef.7fff.c1c6
*
	HEX	71c0.0000.fbe0.0000
	HEX	ffe0.0000.7fc0.0000
	HEX	3f80.0000.1f00.1f80
	HEX	1f00.3fc0.1f7e.7fe0
	HEX	1fff.fff0.1ffe.e7f8
	HEX	0fff.ffff.3ff9.ffff
	HEX	fffc.ffff.fffc.7fff
	HEX	fff8.ffff.ffff.ffff
	HEX	ffff.ff0f.ffff.ff03
	HEX	ffff.fe00.ffff.fc00
	HEX	ffff.fe00.ffff.ffce
	HEX	ffff.ffff.ffff.fffe
	HEX	ffff.fffc.ffff.fff8
	HEX	ffff.fffc.ffff.fffe
	HEX	ffff.ffff.ffff.c1ff
	HEX	ffff.c1ef.7fff.c1c6
	ENDR
*
	RSRC	ICN#,129,32
	HEX	71c7.fffe.cb2c.0001
	HEX	c62c.0001.604f.fff9
	HEX	3087.fff9.1900.0019
	HEX	1900.0019.197e.0019
	HEX	1981.0019.1e8e.0019
	HEX	0ccc.0019.3068.0019
	HEX	c864.0019.c864.0019
	HEX	c8c8.fc19.c99f.8219
	HEX	c981.9919.c9ff.9919
	HEX	c8fd.821f.c801.840e
	HEX	c801.8200.c801.91ce
	HEX	c801.9939.c801.9f32
	HEX	c801.d724.c800.e308
	HEX	c800.0304.cfff.e322
	HEX	c000.1331.c000.1339
	HEX	ffff.e3ef.7fff.c1c6
*
	HEX	71c7.fffe.fbef.ffff
	HEX	ffef.ffff.7fcf.ffff
	HEX	3fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	0fff.ffff.3fff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.fff8.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.fffe.ffff.fffc
	HEX	ffff.fffc.ffff.fffe
	HEX	ffff.f3ff.ffff.f3ff
	HEX	ffff.e3ef.7fff.c1c6
	ENDR
*
	RSRC	ICN#,130,32
	HEX	71c7.fffe.cb2c.0001
	HEX	c62c.0001.604f.fff9
	HEX	3087.fff9.1900.0019
	HEX	1900.0019.1900.0019
	HEX	1900.0019.1e00.0019
	HEX	0c00.0019.3000.0019
	HEX	c800.0019.c800.0019
	HEX	c800.0019.c800.0019
	HEX	c800.0019.c800.0019
	HEX	c800.001f.c800.000f
	HEX	c800.0000.c800.01ce
	HEX	c800.0339.c800.0332
	HEX	c800.0324.c800.0308
	HEX	c800.0304.cfff.e322
	HEX	c000.1331.c000.1339
	HEX	ffff.e3cf.7fff.c1c6
*
	HEX	71c7.fffe.fbef.ffff
	HEX	ffef.ffff.7fff.ffff
	HEX	3fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	0fff.ffff.3fff.ffff
	HEX	7fff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.fffe.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.fffe.ffff.fffc
	HEX	ffff.fffc.ffff.fffe
	HEX	ffff.ffff.ffff.f3ff
	HEX	ffff.e3ef.7fff.c1c6
	ENDR
*
	RSRC	ICN#,131,32
	HEX	71c7.fffe.cb2c.0001
	HEX	c62c.0001.604f.fff9
	HEX	3087.fff9.1900.0019
	HEX	1900.0019.1900.0019
	HEX	1909.1899.1e09.2499
	HEX	0c09.2499.0009.1899
	HEX	7000.0019.c800.0019
	HEX	c989.2319.ca49.2499
	HEX	ca49.2499.c989.2319
	HEX	c800.001f.c800.000f
	HEX	c988.c000.ca49.21ce
	HEX	ca49.2339.c988.c332
	HEX	c800.0324.c800.0308
	HEX	c800.0304.cfff.f322
	HEX	c000.0b31.c000.0b39
	HEX	ffff.f3cf.7fff.e1c6
*
	HEX	71c7.fffe.fbef.ffff
	HEX	ffef.ffff.7fff.ffff
	HEX	3fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	0fff.ffff.0fff.ffff
	HEX	7fff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.fffe.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.fffe.ffff.fffc
	HEX	ffff.fffc.ffff.fffe
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.f7ff.7fff.e7ce
	ENDR
*
	RSRC	ICN#,132,32
	HEX	71c7.fffe.cb2c.0001
	HEX	c62c.0001.604f.fff9
	HEX	3087.fff9.1900.0019
	HEX	197f.0019.1900.0019
	HEX	190f.f019.1e00.0019
	HEX	0c0f.f019.0000.0019
	HEX	7001.fc19.c800.0019
	HEX	c87f.fc19.c800.0019
	HEX	c80f.8019.c800.0019
	HEX	c87f.fe19.c800.001f
	HEX	c80f.f000.c800.01ce
	HEX	c803.c339.c800.0332
	HEX	c8ff.c324.c800.0308
	HEX	c800.0304.cfff.e332
	HEX	c000.1339.c000.133d
	HEX	ffff.f3cf.7fff.e1c6
*
	HEX	638f.fffe.f7cf.ffff
	HEX	ffcf.ffff.7fff.ffff
	HEX	3fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	1fff.ffff.1fff.ffff
	HEX	1fff.ffff.7fff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.ffff.ffff.ffff
	HEX	ffff.fffe.ffff.fffe
	HEX	ffff.fffe.ffff.fffe
	HEX	ffff.fffe.ffff.fffc
	HEX	ffff.fff8.ffff.fffc
	HEX	ffff.fffe.ffff.f3ff
	HEX	ffff.f3ee.7fff.f1c6
	ENDR
*
	RSRC	WIND,256
	DATA	/40,/2,/326,/498
	DATA	/8
	DATA	#1,#0
	DATA	#0,#0
	DATA	0
	STR	"yerk.com"
	ENDR
*
	RSRC	BNDL,128
	ASC	'YERK'
	DATA	/0
	DATA	/2-1
	ASC	'ICN#'
	DATA	/5-1
	DATA	/0,/128,/1,/129,/2,/130
	DATA	/3,/131,/4,/132
	ASC	'FREF'
	DATA	/5-1
	DATA	/0,/128,/1,/129,/2,/130
	DATA	/3,/131,/4,/132
	ENDR
*
	RSRC	SIZE,0
	DATA	/$5800
	DATA	1022976
	DATA	393216
	ENDR
*
	RSRC	SIZE,-1
	DATA	/$5800
	DATA	393216
	DATA	393216
	ENDR
*
	RSRC	vers,1
	DATA	$03308000
	DATA	/0000
	STR	"3.3.0"
	STR	"3.3.0 Yerkes Observatory"
	ENDR
*
	END